crmPack coverage - 49.78%

Files
Source

#' @include Model-class.R
#' @include Samples-class.R
NULL

# doseFunction ----

## generic ----

#' Getting the Dose Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns a [dose()] method that computes the dose reaching a
#' specific target value of a given independent variable, based on the model
#' specific parameters.
#'
#' @param model (`GeneralModel` or `ModelPseudo`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [dose()] method that computes doses.
#'
#' @seealso [dose()], [probFunction()].
#'
#' @export
#' @example examples/Model-method-doseFunction.R
#'
setGeneric(
  name = "doseFunction",
  def = function(model, ...) {
    standardGeneric("doseFunction")
  },
  valueClass = "function"
)

## GeneralModel ----

#' @describeIn doseFunction
#'
#' @aliases doseFunction-GeneralModel
#' @export
#'
setMethod(
  f = "doseFunction",
  signature = "GeneralModel",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_subset(names(model_params), model@sample, empty.ok = FALSE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(x, ...) {
      dose(x = x, model = model, samples = samples, ...)
    }
  }
)

## ModelPseudo ----

#' @describeIn doseFunction
#'
#' @aliases doseFunction-ModelPseudo
#' @export
#'
setMethod(
  f = "doseFunction",
  signature = "ModelPseudo",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(x) {
      dose(x = x, model = model, samples = samples)
    }
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn doseFunction
#'
#' @param grade (`integer`)\cr the toxicity grade for which the dose function is
#' required
#'
#' @aliases doseFunction-LogisticLogNormalOrdinal
#' @example examples/Model-method-doseFunctionLogisticLogNormalOrdinal.R
#' @export
setMethod(
  f = "doseFunction",
  signature = "LogisticLogNormalOrdinal",
  definition = function(model, grade, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )
    assert_integer(grade, lower = 1, len = 1)
    coll <- makeAssertCollection()
    if (!(paste0("alpha", grade) %in% names(model_params))) {
      coll$push(
        paste0(
          "Since grade = ",
          grade,
          ", a parameter named 'alpha",
          grade,
          "' must appear the call"
        )
      )
    }
    reportAssertions(coll)
    # Create dummy intercept columns if necessary
    for (g in seq_along(grade)) {
      if (!(paste0("alpha", g) %in% names(model_params))) {
        model_params[[paste0("alpha", g)]] <- rep(0, length(model_params[[1]]))
      }
    }

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(x) {
      dose(x = x, model = model, samples = samples, grade = grade)
    }
  }
)

# probFunction ----

## generic ----

#' Getting the Prob Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns a [prob()] function that computes the toxicity
#' probabilities for a given dose level, based on the model specific parameters.
#'
#' @param model (`GeneralModel` or `ModelTox`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [prob()] function that computes toxicity probabilities.
#'
#' @seealso [prob()], [doseFunction()].
#'
#' @export
#' @example examples/Model-method-probFunction.R
#'
setGeneric(
  name = "probFunction",
  def = function(model, ...) {
    standardGeneric("probFunction")
  },
  valueClass = "function"
)

## GeneralModel ----

#' @describeIn probFunction
#'
#' @aliases probFunction-GeneralModel
#' @export
#'
setMethod(
  f = "probFunction",
  signature = "GeneralModel",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_subset(names(model_params), model@sample, empty.ok = FALSE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(dose, ...) {
      prob(dose = dose, model = model, samples = samples, ...)
    }
  }
)

## ModelTox ----

#' @describeIn probFunction
#'
#' @aliases probFunction-ModelTox
#' @export
#'
setMethod(
  f = "probFunction",
  signature = "ModelTox",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(dose) {
      prob(dose = dose, model = model, samples = samples)
    }
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn probFunction
#'
#' @param grade (`integer`)\cr the toxicity grade for which the dose function is
#' required
#'
#' @aliases probFunction-LogisticLogNormalOrdinal
#' @example examples/Model-method-probFunctionLogisticLogNormalOrdinal.R
#' @export
setMethod(
  f = "probFunction",
  signature = "LogisticLogNormalOrdinal",
  definition = function(model, grade, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )
    assert_integer(grade, lower = 1, len = 1)
    coll <- makeAssertCollection()
    if (!(paste0("alpha", grade) %in% names(model_params))) {
      coll$push(
        paste0(
          "Since grade = ",
          grade,
          ", a parameter named 'alpha",
          grade,
          "' must appear the call"
        )
      )
    }
    reportAssertions(coll)
    # Create dummy intercept columns if necessary
    for (g in seq_along(grade)) {
      if (!(paste0("alpha", g) %in% names(model_params))) {
        model_params[[paste0("alpha", g)]] <- rep(0, length(model_params[[1]]))
      }
    }

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(dose) {
      prob(dose = dose, model = model, samples = samples, grade = grade)
    }
  }
)


# efficacyFunction ----

## generic ----

#' Getting the Efficacy Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns an [efficacy()] function that computes expected
#' efficacy for a given dose level, based on the model specific parameters.
#'
#' @param model (`ModelEff`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [efficacy()] function that computes expected efficacy.
#'
#' @seealso [efficacy()].
#'
#' @export
#' @example examples/Model-method-efficacyFunction.R
#'
setGeneric(
  name = "efficacyFunction",
  def = function(model, ...) {
    standardGeneric("efficacyFunction")
  },
  valueClass = "function"
)

## ModelEff ----

#' @describeIn efficacyFunction
#'
#' @aliases efficacyFunction-ModelEff
#' @export
#'
setMethod(
  f = "efficacyFunction",
  signature = "ModelEff",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(dose) {
      efficacy(dose = dose, model = model, samples = samples)
    }
  }
)

# dose ----

## generic ----

#' Computing the Doses for a given independent variable, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the dose reaching a specific target value of a
#' given variable that dose depends on. The meaning of this variable depends
#' on the type of the model. For instance, for single agent dose escalation
#' model or pseudo DLE (dose-limiting events)/toxicity model, this variable
#' represents the a probability of the occurrence of a DLE. For efficacy models,
#' it represents expected efficacy.
#' The doses are computed based on the samples of the model parameters (samples).
#'
#' @details The `dose()` function computes the doses corresponding to a value of
#'   a given independent variable, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `dose()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @note The [dose()] and [prob()] methods are the inverse of each other, for
#'   all [dose()] methods for which its first argument, i.e. a given independent
#'   variable that dose depends on, represents toxicity probability.
#'
#' @param x (`proportion` or `numeric`)\cr a value of an independent variable
#'   on which dose depends.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `x` must have the same size
#'   as the sample.
#' @param model (`GeneralModel` or `ModelPseudo`)\cr the model.
#' @param samples (`Samples`)\cr the samples of model's parameters that will be
#'   used to compute the resulting doses. Can also be missing for some models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `number` or `numeric` vector with the doses.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `prob`.
#'
#' @seealso [doseFunction()], [prob()], [efficacy()].
#'
#' @export
#' @example examples/Model-method-dose.R
#'
setGeneric(
  name = "dose",
  def = function(x, model, samples, ...) {
    standardGeneric("dose")
  },
  valueClass = "numeric"
)

## LogisticNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' In the case of a `LogisticLogNormalOrdinal` model, `dose` returns only the
#' probability of toxicity at the given grade or higher
#'
#' @param grade (`integer`)\cr The toxicity grade for which probabilities are required
#'
#' @aliases dose-LogisticLogNormalOrdinal
#' @example examples/Model-method-doseLogisticLogNormalOrdinal.R
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalOrdinal",
    samples = "Samples"
  ),
  definition = function(x, model, samples, grade) {
    assert_probabilities(x)
    assert_length(x, len = size(samples))
    assert_integer(
      grade,
      len = 1,
      lower = 1,
      upper = (length(names(samples@data)) - 1)
    )
    a <- paste0("alpha", grade)
    assert_subset(c(a, "beta"), names(samples))

    alpha <- samples@data[[a]]
    beta <- samples@data$beta
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha) / beta) * ref_dose
  }
)

## LogisticLogNormalSub ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormalSub
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalSub",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- model@ref_dose
    ((logit(x) - alpha0) / alpha1) + ref_dose
  }
)

## ProbitLogNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-ProbitLogNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "ProbitLogNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((probit(x) - alpha0) / alpha1) * ref_dose
  }
)

## ProbitLogNormalRel ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-ProbitLogNormalRel
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "ProbitLogNormalRel",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    ((probit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalGrouped ----

#' @describeIn dose method for [`LogisticLogNormalGrouped`] which needs `group`
#'   argument in addition.
#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`],
#'   indicating whether to calculate the dose for the `mono` or for
#'   the `combo` arm.
#' @aliases dose-LogisticLogNormalGrouped
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalGrouped",
    samples = "Samples"
  ),
  definition = function(x, model, samples, group) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples))
    assert_length(x, len = size(samples))
    assert_multi_class(group, c("character", "factor"))
    assert_subset(as.character(group), choices = c("mono", "combo"))
    assert_length(group, len = size(samples))

    alpha0 <- samples@data$alpha0
    delta0 <- samples@data$delta0
    alpha1 <- samples@data$alpha1
    delta1 <- samples@data$delta1
    ref_dose <- as.numeric(model@ref_dose)
    is_combo <- as.integer(group == "combo")
    exp(
      (logit(x) - (alpha0 + is_combo * delta0)) / (alpha1 + is_combo * delta1)
    ) *
      ref_dose
  }
)

## LogisticKadane ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticKadane
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticKadane",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(x, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * (logit(x) - logit(rho0)) + xmin * (logit(theta) - logit(x))
    num / (logit(theta) - logit(rho0))
  }
)

## LogisticKadaneBetaGamma ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticKadaneBetaGamma
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticKadaneBetaGamma",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(x, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * (logit(x) - logit(rho0)) + xmin * (logit(theta) - logit(x))
    num / (logit(theta) - logit(rho0))
  }
)

## LogisticNormalMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormalMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormalMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticNormalFixedMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormalFixedMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormalFixedMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormalMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    stop("not implemented")
  }
)

## DualEndpoint ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-DualEndpoint
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("betaZ", names(samples))
    assert_length(x, len = size(samples))

    betaZ <- samples@data$betaZ
    ref_dose <- as.numeric(model@ref_dose)
    dose_temp <- (qnorm(x) - betaZ[, 1]) / betaZ[, 2]
    if (model@use_log_dose) {
      exp(dose_temp) * ref_dose
    } else {
      dose_temp * ref_dose
    }
  }
)

## LogisticIndepBeta ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticIndepBeta
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticIndepBeta",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("phi1", "phi2"), names(samples))
    assert_length(x, len = size(samples))

    phi1 <- samples@data$phi1
    phi2 <- samples@data$phi2
    log_dose <- (log(x / (1 - x)) - phi1) / phi2
    exp(log_dose)
  }
)

## LogisticIndepBeta-noSamples ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'   All model parameters (except `x`) should be present in the `model` object.
#'
#' @aliases dose-LogisticIndepBeta-noSamples
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticIndepBeta",
    samples = "missing"
  ),
  definition = function(x, model) {
    assert_probabilities(x)
    model_params <- h_slots(model, c("phi1", "phi2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = nsamples)
    )
    assert_length(x, len = nsamples)

    dose(x, model, samples)
  }
)

## Effloglog-noSamples ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'   All model parameters (except `x`) should be present in the `model` object.
#'
#' @aliases dose-Effloglog-noSamples
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "Effloglog",
    samples = "missing"
  ),
  definition = function(x, model) {
    assert_numeric(x, min.len = 1L, any.missing = FALSE, finite = TRUE)
    theta1 <- model@theta1
    theta2 <- model@theta2
    constant <- model@const
    assert_scalar(theta1)
    assert_scalar(theta2)
    assert_scalar(constant)

    exp(exp((x - theta1) / theta2)) - constant
  }
)

## EffFlexi ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`). For this method `x` must
#'   be a scalar.
#'
#' @aliases dose-EffFlexi
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "EffFlexi",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_number(x)
    assert_subset("ExpEff", names(samples))

    samples_efficacy <- samples@data$ExpEff
    dose_grid <- model@data@doseGrid

    # Find dose level for a given expected efficacy level using linear interpolation.
    apply(samples_efficacy, 1, function(se) {
      se_leq_x <- se <= x
      dose_level0 <- max(which(se_leq_x))
      dose_level1 <- min(which(!se_leq_x))
      eff0 <- se[dose_level0]
      eff1 <- se[dose_level1]
      dose0 <- dose_grid[dose_level0]
      dose1 <- dose_grid[dose_level1]
      dose0 + (dose1 - dose0) * ((x - eff0) / (eff1 - eff0))
    })
  }
)

## OneParLogNormalPrior ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLT (`x`).
#'
#' @aliases dose-OneParLogNormalPrior
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "OneParLogNormalPrior",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("alpha", names(samples))
    assert_length(x, len = size(samples))

    alpha <- samples@data$alpha
    skel_fun_inv <- model@skel_fun_inv
    skel_fun_inv(x^(1 / exp(alpha)))
  }
)

## OneParExpPrior ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLT (`x`).
#'
#' @aliases dose-OneParExpPrior
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "OneParExpPrior",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("theta", names(samples))
    assert_length(x, len = size(samples))

    theta <- samples@data$theta
    skel_fun_inv <- model@skel_fun_inv
    assert_numeric(theta, lower = .Machine$double.xmin, finite = TRUE)
    skel_fun_inv(x^(1 / theta))
  }
)

# prob ----

## generic ----

#' Computing Toxicity Probabilities for a Given Dose, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the probability of the occurrence of a DLE at a
#' specified dose level, based on the model parameters (samples).
#'
#' @details The `prob()` function computes the probability of toxicity for given
#'   doses, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `prob()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @note The [prob()] and [dose()] functions are the inverse of
#'   each other, for all [dose()] methods for which its first argument, i.e. a
#'   given independent variable that dose depends on, represents toxicity
#'   probability.
#'
#' @param dose (`number` or `numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `dose` must have the same
#'   size as the sample.
#' @param model (`GeneralModel` or `ModelTox`)\cr the model for single agent
#'   dose escalation or pseudo DLE (dose-limiting events)/toxicity model.
#' @param samples (`Samples`)\cr the samples of model's parameters that will be
#'   used to compute toxicity probabilities. Can also be missing for some models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `proportion` or `numeric` vector with the toxicity probabilities.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `dose`.  In the
#'   case of `LogisticLogNormalOrdinal`, the probabilities relate to toxicities
#'   of  grade given by `grade`.
#'
#' @seealso [probFunction()], [dose()], [efficacy()].
#'
#' @export
#' @example examples/Model-method-prob.R
#'
setGeneric(
  name = "prob",
  def = function(dose, model, samples, ...) {
    standardGeneric("prob")
  },
  valueClass = c("numeric", "list")
)

## LogisticNormal ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormal ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormalSub ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormalSub
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalSub",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- model@ref_dose
    plogis(alpha0 + alpha1 * (dose - ref_dose))
  }
)

## ProbitLogNormal ----

#' @describeIn prob
#'
#' @aliases prob-ProbitLogNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "ProbitLogNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    pnorm(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## ProbitLogNormalRel ----

#' @describeIn prob
#'
#' @aliases prob-ProbitLogNormalRel
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "ProbitLogNormalRel",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    pnorm(alpha0 + alpha1 * (dose / ref_dose))
  }
)

## LogisticLogNormalGrouped ----

#' @describeIn prob method for [`LogisticLogNormalGrouped`] which needs `group`
#'   argument in addition.
#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`],
#'   indicating whether to calculate the probability for the `mono` or for
#'   the `combo` arm.
#' @aliases prob-LogisticLogNormalGrouped
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalGrouped",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, group, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples))
    assert_length(dose, len = size(samples))
    assert_multi_class(group, c("character", "factor"))
    assert_subset(as.character(group), choices = c("mono", "combo"))
    assert_length(group, len = size(samples))

    alpha0 <- samples@data$alpha0
    delta0 <- samples@data$delta0
    alpha1 <- samples@data$alpha1
    delta1 <- samples@data$delta1
    ref_dose <- as.numeric(model@ref_dose)
    is_combo <- as.integer(group == "combo")
    plogis(
      (alpha0 + is_combo * delta0) +
        (alpha1 + is_combo * delta1) * log(dose / ref_dose)
    )
  }
)

## LogisticKadane ----

#' @describeIn prob
#'
#' @aliases prob-LogisticKadane
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticKadane",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(dose, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma *
      logit(rho0) -
      xmin * logit(theta) +
      (logit(theta) - logit(rho0)) * dose
    plogis(num / (gamma - xmin))
  }
)

## LogisticKadaneBetaGamma ----

#' @describeIn prob
#'
#' @aliases prob-LogisticKadaneBetaGamma
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticKadaneBetaGamma",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(dose, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma *
      logit(rho0) -
      xmin * logit(theta) +
      (logit(theta) - logit(rho0)) * dose
    plogis(num / (gamma - xmin))
  }
)

## LogisticNormalMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormalMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormalMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticNormalFixedMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormalFixedMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormalFixedMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormalMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormalMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    comp <- samples@data$comp
    ref_dose <- as.numeric(model@ref_dose)
    sel <- cbind(seq_along(comp), comp)
    plogis(alpha0[sel] + alpha1[sel] * log(dose / ref_dose))
  }
)

## DualEndpoint ----

#' @describeIn prob
#'
#' @aliases prob-DualEndpoint
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("betaZ", names(samples))
    assert_length(dose, len = size(samples))

    betaZ <- samples@data$betaZ
    ref_dose <- as.numeric(model@ref_dose)
    stand_dose <- if (model@use_log_dose) {
      log(dose / ref_dose)
    } else {
      dose / ref_dose
    }
    pnorm(betaZ[, 1] + betaZ[, 2] * stand_dose)
  }
)

## LogisticIndepBeta ----

#' @describeIn prob compute toxicity probabilities of the occurrence of a DLE at
#' a specified dose level, based on the samples of [`LogisticIndepBeta`] model
#' parameters.
#'
#' @aliases prob-LogisticIndepBeta
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticIndepBeta",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("phi1", "phi2"), names(samples))
    assert_length(dose, len = size(samples))

    phi1 <- samples@data$phi1
    phi2 <- samples@data$phi2
    log_dose <- log(dose)
    exp(phi1 + phi2 * log_dose) / (1 + exp(phi1 + phi2 * log_dose))
  }
)

## LogisticIndepBeta-noSamples ----

#' @describeIn prob compute toxicity probabilities of the occurrence of a DLE at
#' a specified dose level, based on the [`LogisticIndepBeta`] model parameters.
#' All model parameters (except `dose`) should be present in the `model` object.
#'
#' @aliases prob-LogisticIndepBeta-noSamples
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticIndepBeta",
    samples = "missing"
  ),
  definition = function(dose, model, ...) {
    model_params <- h_slots(model, c("phi1", "phi2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = nsamples)
    )

    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_length(dose, len = nsamples)

    prob(dose, model, samples)
  }
)

## OneParLogNormalPrior ----

#' @describeIn prob
#'
#' @aliases prob-OneParLogNormalPrior
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "OneParLogNormalPrior",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("alpha", names(samples))
    assert_length(dose, len = size(samples))

    alpha <- samples@data$alpha
    skel_fun <- model@skel_fun
    skel_fun(dose)^exp(alpha)
  }
)

## OneParExpPrior ----

#' @describeIn prob
#'
#' @aliases prob-OneParExpPrior
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "OneParExpPrior",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("theta", names(samples))
    assert_length(dose, len = size(samples))

    theta <- samples@data$theta
    skel_fun <- model@skel_fun
    skel_fun(dose)^theta
  }
)

## LogisticLogNormalOrdinal ----

#' Calculate a grade-specific probability of toxicity for a given dose.
#' @describeIn prob
#'
#' @param grade (`integer` or `integer_vector`)\cr The toxicity grade for which probabilities are required
#' @param cumulative (`flag`)\cr Should the returned probability be cumulative
#' (the default) or grade-specific?
#' @aliases prob-LogisticLogNormalOrdinal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalOrdinal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, grade, cumulative = TRUE, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_integer(
      grade,
      min.len = 1,
      max.len = length(model@params@mean) - 1,
      lower = 0,
      upper = length(model@params@mean) - 1
    )
    assert_subset(
      names(samples),
      c(paste0("alpha", 0:(length(model@params@mean) - 1)), "beta")
    )
    assert_length(dose, len = size(samples))
    assert_flag(cumulative)

    rv <- lapply(
      grade,
      function(g) {
        alpha <- samples@data[[paste0("alpha", g)]]
        beta <- samples@data$beta
        ref_dose <- as.numeric(model@ref_dose)

        cumulative_prob <- plogis(alpha + beta * log(dose / ref_dose))
        if (cumulative | g == as.integer(length(model@params@mean) - 1)) {
          return(cumulative_prob)
        }

        # Calculate grade-specific probabilities
        alpha0 <- samples@data[[paste0("alpha", g + 1)]]
        grade_prob <- cumulative_prob -
          plogis(alpha0 + beta * log(dose / ref_dose))
        grade_prob
      }
    )
    if (length(rv) == 1) {
      return(rv[[1]])
    }
    names(rv) <- as.character(grade)
    return(rv)
  }
)

# efficacy ----

## generic ----

#' Computing Expected Efficacy for a Given Dose, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the value of expected efficacy at a specified dose
#' level, based on the model specific parameters. The model parameters (samples)
#' are obtained based on prior specified in form of pseudo data combined with
#' observed responses (if any).
#'
#' @details The `efficacy()` function computes the expected efficacy for given
#'   doses, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `efficacy()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @param dose (`numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `dose` must have the same
#'   size as the sample.
#' @param model (`ModelEff`)\cr the efficacy model with pseudo data prior.
#' @param samples (`Samples`)\cr samples of model's parameters that will be
#'   used to compute expected efficacy values. Can also be missing for some
#'   models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `numeric` vector with the values of expected efficacy.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `dose`.
#'
#' @seealso [dose()], [prob()].
#'
#' @export
#' @example examples/Model-method-efficacy.R
setGeneric(
  name = "efficacy",
  def = function(dose, model, samples, ...) {
    standardGeneric("efficacy")
  },
  valueClass = "numeric"
)

## Effloglog ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the samples of [`Effloglog`] model parameters.
#'
#' @aliases efficacy-Effloglog
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "Effloglog",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("theta1", "theta2"), names(samples))
    assert_length(dose, len = size(samples))

    theta1 <- samples@data$theta1
    theta2 <- samples@data$theta2
    constant <- model@const
    theta1 + theta2 * log(log(dose + constant))
  }
)

## Effloglog-noSamples ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the [`Effloglog`] model parameters.
#' All model parameters (except `dose`) should be present in the `model` object.
#'
#' @aliases efficacy-Effloglog-noSamples
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "Effloglog",
    samples = "missing"
  ),
  definition = function(dose, model) {
    model_params <- h_slots(model, c("theta1", "theta2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = nsamples)
    )

    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_length(dose, len = nsamples)

    efficacy(dose, model, samples)
  }
)

## EffFlexi ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the samples of [`EffFlexi`] model parameters. If a given dose in
#' the `dose` vector is from outside of the dose grid range, the `NA_real` is
#' returned for this dose and the warning is thrown.
#'
#' @aliases efficacy-EffFlexi
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "EffFlexi",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    n_samples <- size(samples)
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_true(model@data@nGrid >= 1L)
    assert_subset("ExpEff", names(samples))
    assert_length(dose, len = n_samples)

    dose_grid <- model@data@doseGrid
    dose_level <- match_within_tolerance(dose, dose_grid)
    dose[which(!is.na(dose_level))] <- dose_grid[stats::na.omit(dose_level)]

    # linear interpolation, NA for doses that are outside of the dose_grid range.
    samples_eff <- samples@data$ExpEff
    eff <- if (length(dose) == n_samples) {
      sapply(seq_len(n_samples), function(s) {
        stats::approx(dose_grid, samples_eff[s, ], xout = dose[s])$y
      })
    } else {
      eff <- apply(samples_eff, 1, function(s) {
        stats::approx(dose_grid, s, xout = dose)$y
      })
      as.vector(eff)
    }

    if (any(is.na(eff))) {
      warning(
        paste(
          "At least one dose out of",
          paste(dose, collapse = ", "),
          "is outside of the dose grid range"
        )
      )
    }
    eff
  }
)

# biomarker ----

## generic ----

#' Get the Biomarker Levels for a Given Dual-Endpoint Model, Given Dose Levels and Samples
#'
#' @details This function simply returns a specific columns (with the indices equal
#' to `xLevel`) of the biomarker samples matrix, which is included in the the
#' `samples` object.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @param xLevel (`integer`)\cr the levels for the doses the patients have been
#'   given w.r.t dose grid. See [`Data`] for more details.
#' @param model (`DualEndpoint`)\cr the model.
#' @param samples (`Samples`)\cr the samples of model's parameters that store
#'   the value of biomarker levels for all doses on the dose grid.
#' @param ... not used.
#'
#' @return The biomarker levels.
#'
#' @export
#' @example examples/Model-method-biomarker.R
#'
setGeneric(
  name = "biomarker",
  def = function(xLevel, model, samples, ...) {
    standardGeneric("biomarker")
  },
  valueClass = c("numeric", "array")
)

## DualEndpoint ----

#' @describeIn biomarker
#'
#' @aliases biomarker-DualEndpoint
#' @export
#'
setMethod(
  f = "biomarker",
  signature = signature(
    xLevel = "integer",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  def = function(xLevel, model, samples, ...) {
    assert_integer(
      xLevel,
      lower = 1,
      upper = ncol(samples@data$betaW),
      any.missing = FALSE,
      min.len = 1
    )

    samples@data$betaW[, xLevel]
  }
)

# gain ----

## generic ----

#' Compute Gain Values based on Pseudo DLE and a Pseudo Efficacy Models and
#' Using Optional Samples.
#'
#' @details This function computes the gain values for a given dose level,
#' pseudo DLE and Efficacy models as well as a given DLE and Efficacy samples.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param dose (`number` or `numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when samples are not missing: vectors
#'   of size 1 will be recycled to the size of the sample. Otherwise, `dose`
#'   must have the same size as the sample.
#' @param model_dle (`ModelTox`)\cr pseudo DLE (dose-limiting events)/toxicity
#'   model.
#' @param samples_dle (`Samples`)\cr the samples of model's
#'   parameters that will be used to compute toxicity probabilities. Can also be
#'   missing for some models.
#' @param model_eff (`ModelEff`)\cr the efficacy model with pseudo data prior.
#' @param samples_eff (`Samples`)\cr samples of model's parameters that will be
#'   used to compute expected efficacy values. Can also be missing for some
#'   models.
#' @param ... not used.
#'
#' @return The gain values.
#'
#' @export
#' @example examples/Model-method-gain.R
#'
setGeneric(
  name = "gain",
  def = function(dose, model_dle, samples_dle, model_eff, samples_eff, ...) {
    standardGeneric("gain")
  },
  valueClass = "numeric"
)

## ModelTox-ModelEff ----

#' @describeIn gain
#'
#' @aliases gain-ModelTox-ModelEff
#' @export
#'
setMethod(
  f = "gain",
  signature = signature(
    dose = "numeric",
    model_dle = "ModelTox",
    samples_dle = "Samples",
    model_eff = "ModelEff",
    samples_eff = "Samples"
  ),
  definition = function(
    dose,
    model_dle,
    samples_dle,
    model_eff,
    samples_eff,
    ...
  ) {
    dle <- prob(dose, model_dle, samples_dle)
    eff <- efficacy(dose, model_eff, samples_eff)
    assert_length(dle, len = length(eff))
    eff / (1 + (dle / (1 - dle)))
  }
)

## ModelTox-ModelEff-noSamples----

#' @describeIn gain Compute the gain value for a given dose level, pseudo DLE
#'   and Efficacy models without DLE and the Efficacy samples.
#'
#' @aliases gain-ModelTox-Effloglog-noSamples
#' @export
#' @example examples/Model-method-gainNoSamples.R
#'
setMethod(
  f = "gain",
  signature = signature(
    dose = "numeric",
    model_dle = "ModelTox",
    samples_dle = "missing",
    model_eff = "Effloglog",
    samples_eff = "missing"
  ),
  definition = function(dose, model_dle, model_eff, ...) {
    dle <- prob(dose, model_dle)
    eff <- efficacy(dose, model_eff)
    assert_length(dle, len = length(eff))
    eff / (1 + (dle / (1 - dle)))
  }
)

# update ----

## ModelPseudo ----

#' Update method for the [`ModelPseudo`] model class. This is a method to update
#' the model class slots (estimates, parameters, variables and etc.), when the
#' new data (e.g. new observations of responses) are available. This method is
#' mostly used to obtain new modal estimates for pseudo model parameters.
#'
#' @param object (`ModelPseudo`)\cr the model to update.
#' @param data (`Data`)\cr all currently available of data.
#' @param ... not used.
#'
#' @return the new [`ModelPseudo`] class object.
#'
#' @aliases update-ModelPseudo
#' @export
#' @example examples/Model-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(
    object = "ModelPseudo"
  ),
  definition = function(object, data, ...) {
    assert_class(data, "Data")

    constructor_name <- class(object)
    arg_names <- setdiff(formalArgs(constructor_name), "data")
    do.call(
      constructor_name,
      c(h_slots(object, arg_names), list(data = data))
    )
  }
)

# tidy ----

# LogisticIndepBeta

#' Tidy Method for the [`LogisticIndepBeta`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`LogisticIndepBeta`] object.
#'
#' @return The [`list`] of [`tibble`] objects.
#'
#' @aliases tidy-LogisticIndepBeta
#' @rdname tidy
#' @method tidy LogisticIndepBeta
#' @export
#' @example examples/LogisticIndepBeta-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "LogisticIndepBeta"),
  definition = function(x, ...) {
    start <- callNextMethod()
    # N$DLEweights Dose$DLEdose Tox$binDLE
    pseudoData <- tibble::tibble(
      Dose = dplyr::pull(start$DLEdose),
      N = dplyr::pull(start$DLEweights),
      Tox = dplyr::pull(start$binDLE)
    )
    params <- tibble::tibble(
      Param = c("Phi1", "Phi2"),
      mean = c(dplyr::pull(start$phi1), dplyr::pull(start$phi2)),
      cov = as.list(start$Pcov)
    )
    list(
      pseudoData = pseudoData,
      data = start$data,
      params = params
    ) %>%
      h_tidy_class(x)
  }
)

# Effloglog

#' Tidy Method for the [`Effloglog`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`Effloglog`] object.
#'
#' @return The [`list`] of [`tibble`] objects.
#'
#' @aliases tidy-Effloglog
#' @rdname tidy
#' @method tidy Edffloglog
#' @export
#' @example examples/Effloglog-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "Effloglog"),
  definition = function(x, ...) {
    start <- callNextMethod()
    pseudoData <- tibble::tibble(
      Dose = dplyr::pull(start$eff_dose),
      Response = dplyr::pull(start$eff)
    )
    params <- tibble::tibble(
      Param = c("theta1", "theta2"),
      mean = c(dplyr::pull(start$theta1), dplyr::pull(start$theta2)),
      cov = as.list(start$Pcov)
    )
    list(
      pseudoData = pseudoData,
      data = start$data,
      params = params
    ) %>%
      h_tidy_class(x)
  }
)

#' @include Data-methods.R
#' @include Design-class.R
#' @include McmcOptions-class.R
#' @include Rules-methods.R
#' @include Simulations-class.R
#' @include helpers.R
#' @include mcmc.R
NULL

# simulate ----

## Design ----

#' Simulate outcomes from a CRM design
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param object the [`Design`] object we want to simulate data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and returns the
#'   true probability (vector) for toxicity. Additional arguments can be supplied
#'   in `args`.
#' @param args (`data.frame`)\cr data frame with arguments for the `truth` function. The
#'   column names correspond to the argument names, the rows to the values of the
#'   arguments. The rows are appropriately recycled in the `nsim`
#'   simulations. In order to produce outcomes from the posterior predictive
#'   distribution, e.g, pass an `object` that contains the data observed so
#'   far, `truth` contains the `prob` function from the model in
#'   `object`, and `args` contains posterior samples from the model.
#' @param firstSeparate (`flag`)\cr enroll the first patient separately from the rest of
#'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
#'   in this patient.
#' @param mcmcOptions ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#' @param derive (`list`)\cr a named list of functions which derives statistics, based on the
#'   vector of posterior MTD samples. Each list element must therefore accept
#'   one and only one argument, which is a numeric vector, and return a number.
#'
#' @return an object of class [`Simulations`]
#'
#' @example examples/design-method-simulate-Design.R
#' @export
#' @importFrom parallel detectCores
setMethod(
  f = "simulate",
  signature = signature(
    object = "Design",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5),
    derive = list(),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)
    sim_seeds <- sample.int(n = 2147483647, size = as.integer(nsim))

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]
      data <- object@data
      prob_placebo <- NULL
      cohort_size_placebo <- NULL

      if (data@placebo) {
        prob_placebo <- h_this_truth(
          object@data@doseGrid[1],
          current_args,
          truth
        )
      }

      should_stop <- FALSE
      dose <- object@startingDose

      while (!should_stop) {
        prob <- h_this_truth(dose, current_args, truth)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        } else {
          cohort_size_placebo <- NULL
        }

        data <- h_determine_dlts(
          data = data,
          dose = dose,
          prob = prob,
          prob_placebo = prob_placebo,
          cohort_size = cohort_size,
          cohort_size_placebo = cohort_size_placebo,
          dose_grid = object@data@doseGrid[1],
          first_separate = firstSeparate
        )

        dose_limit <- maxDose(object@increments, data = data)
        samples <- mcmc(
          data = data,
          model = object@model,
          options = mcmcOptions
        )

        dose <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = object@model,
          data = data
        )$value

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          samples = samples,
          model = object@model,
          data = data
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      fit_model <- fit(object = samples, model = object@model, data = data)
      target_dose_samples <- dose(
        mean(object@nextBest@target),
        model = object@model,
        samples = samples
      )
      additional_stats <- lapply(derive, function(f) f(target_dose_samples))

      list(
        data = data,
        dose = dose,
        fit = subset(fit_model, select = c(middle, lower, upper)),
        stop = attr(should_stop, "message"),
        report_results = stopit_results,
        additional_stats = additional_stats
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "truth",
        "object",
        "mcmcOptions"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    simulations_output <- h_simulations_output_format(result_list)

    Simulations(
      data = simulations_output$dataList,
      doses = simulations_output$recommendedDoses,
      fit = simulations_output$fitList,
      stop_report = simulations_output$stop_matrix,
      stop_reasons = simulations_output$stopReasons,
      additional_stats = simulations_output$additional_stats,
      seed = rng_state
    )
  }
)

## RuleDesign ----

#' Simulate outcomes from a rule-based design
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param object the [`RuleDesign`] object we want to simulate data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and returns the
#'   true probability (vector) for toxicity. Additional arguments can be supplied
#'   in `args`.
#' @param args (`data.frame`)\cr data frame with arguments for the `truth` function. The
#'   column names correspond to the argument names, the rows to the values of the
#'   arguments. The rows are appropriately recycled in the `nsim`
#'   simulations.
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`GeneralSimulations`]
#'
#' @example examples/design-method-simulate-RuleDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "RuleDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)
    assert_class(object, "RuleDesign")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)
    sim_seeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      truth_with_args <- function(dose) {
        do.call(truth, c(dose, current_args))
      }

      data <- object@data
      should_stop <- FALSE
      dose <- object@startingDose

      while (!should_stop) {
        prob <- truth_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        dlts <- rbinom(n = cohort_size, size = 1L, prob = prob)
        data <- update(object = data, x = dose, y = dlts)

        outcome <- nextBest(object@nextBest, data = data)
        dose <- outcome$value
        should_stop <- outcome$stopHere
      }

      list(data = data, dose = dose)
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "truth",
        "object"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")
    recommended_doses <- as.numeric(sapply(result_list, "[[", "dose"))

    GeneralSimulations(
      data = data_list,
      doses = recommended_doses,
      seed = rng_state
    )
  }
)

## DualDesign ----

#' Simulate outcomes from a dual-endpoint design
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param object the [`DualDesign`] object we want to simulate data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param trueTox (`function`)\cr a function which takes as input a dose (vector) and returns the
#'   true probability (vector) for toxicity. Additional arguments can be supplied
#'   in `args`.
#' @param trueBiomarker (`function`)\cr a function which takes as input a dose (vector) and
#'   returns the true biomarker level (vector). Additional arguments can be
#'   supplied in `args`.
#' @param args (`data.frame`)\cr data frame with arguments for the `trueTox` and
#'   `trueBiomarker` function. The column names correspond to the argument
#'   names, the rows to the values of the arguments. The rows are appropriately
#'   recycled in the `nsim` simulations.
#' @param sigma2W (`number`)\cr variance for the biomarker measurements
#' @param rho (`number`)\cr correlation between toxicity and biomarker measurements (default: 0)
#' @param firstSeparate (`flag`)\cr enroll the first patient separately from the rest of
#'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
#'   in this patient.
#' @param mcmcOptions ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#' @param derive (`list`)\cr a named list of functions which derives statistics, based on the
#'   vector of posterior MTD samples. Each list element must therefore accept
#'   one and only one argument, which is a numeric vector, and return a number.
#'
#' @return an object of class [`DualSimulations`]
#'
#' @example examples/design-method-simulate-DualDesign.R
#' @importFrom mvtnorm rmvnorm
#' @export
setMethod(
  f = "simulate",
  signature = signature(object = "DualDesign"),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    trueTox,
    trueBiomarker,
    args = NULL,
    sigma2W,
    rho = 0,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5),
    derive = list(),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(trueTox)
    assert_function(trueBiomarker)
    assert_number(sigma2W, lower = 0)
    assert_number(rho, lower = -1, upper = 1)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)
    assert_class(object, "DualDesign")
    assert_list(derive)

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)

    tox_arg_names <- names(formals(trueTox))[-1]
    biomarker_arg_names <- names(formals(trueBiomarker))[-1]

    covariance_matrix <- matrix(
      c(
        sigma2W,
        sqrt(sigma2W) * rho,
        sqrt(sigma2W) * rho,
        1
      ),
      nrow = 2,
      byrow = TRUE
    )

    rng_state <- set_seed(seed)
    sim_seeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      tox_with_args <- function(dose) {
        do.call(
          trueTox,
          c(dose, as.list(current_args)[tox_arg_names])
        )
      }

      biomarker_with_args <- function(dose) {
        do.call(
          trueBiomarker,
          c(dose, as.list(current_args)[biomarker_arg_names])
        )
      }

      data <- object@data
      should_stop <- FALSE
      dose <- object@startingDose

      prob_placebo <- NULL
      mean_z_placebo <- NULL
      mean_biomarker_placebo <- NULL

      if (data@placebo) {
        prob_placebo <- tox_with_args(object@data@doseGrid[1])
        mean_z_placebo <- qlogis(prob_placebo)
        mean_biomarker_placebo <- biomarker_with_args(object@data@doseGrid[1])
      }

      while (!should_stop) {
        prob <- tox_with_args(dose)
        mean_z <- qlogis(prob)
        mean_biomarker <- biomarker_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        cohort_size_placebo <- NULL
        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        response_data <- if (firstSeparate && (cohort_size > 1L)) {
          first_patient <- mvtnorm::rmvnorm(
            n = 1,
            mean = c(mean_biomarker, mean_z),
            sigma = covariance_matrix
          )

          first_patient_placebo <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            first_patient_placebo <- mvtnorm::rmvnorm(
              n = 1,
              mean = c(mean_biomarker_placebo, mean_z_placebo),
              sigma = covariance_matrix
            )
          }

          if (first_patient[, 2] < 0) {
            remaining_patients <- mvtnorm::rmvnorm(
              n = cohort_size - 1,
              mean = c(mean_biomarker, mean_z),
              sigma = covariance_matrix
            )
            first_patient <- rbind(first_patient, remaining_patients)

            if (data@placebo && (cohort_size_placebo > 0L)) {
              remaining_patients_placebo <- mvtnorm::rmvnorm(
                n = cohort_size_placebo,
                mean = c(mean_biomarker_placebo, mean_z_placebo),
                sigma = covariance_matrix
              )
              first_patient_placebo <- rbind(
                first_patient_placebo,
                remaining_patients_placebo
              )
            }
          }

          if (data@placebo && (cohort_size_placebo > 0L)) {
            list(active = first_patient, placebo = first_patient_placebo)
          } else {
            list(active = first_patient)
          }
        } else {
          active_responses <- mvtnorm::rmvnorm(
            n = cohort_size,
            mean = c(mean_biomarker, mean_z),
            sigma = covariance_matrix
          )

          placebo_responses <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            placebo_responses <- mvtnorm::rmvnorm(
              n = cohort_size_placebo,
              mean = c(mean_biomarker_placebo, mean_z_placebo),
              sigma = covariance_matrix
            )
          }

          if (data@placebo && (cohort_size_placebo > 0L)) {
            list(active = active_responses, placebo = placebo_responses)
          } else {
            list(active = active_responses)
          }
        }

        biomarkers <- response_data$active[, 1]
        dlts <- as.integer(response_data$active[, 2] > 0)

        if (data@placebo && (cohort_size_placebo > 0L)) {
          biomarkers_placebo <- response_data$placebo[, 1]
          dlts_placebo <- as.integer(response_data$placebo[, 2] > 0)

          data <- update(
            object = data,
            x = object@data@doseGrid[1],
            y = dlts_placebo,
            w = biomarkers_placebo,
            check = FALSE
          )

          data <- update(
            object = data,
            x = dose,
            y = dlts,
            w = biomarkers,
            new_cohort = FALSE
          )
        } else {
          data <- update(
            object = data,
            x = dose,
            y = dlts,
            w = biomarkers
          )
        }

        dose_limit <- maxDose(object@increments, data = data)
        samples <- mcmc(
          data = data,
          model = object@model,
          options = mcmcOptions
        )

        dose <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = object@model,
          data = data
        )$value

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          samples = samples,
          model = object@model,
          data = data
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      fit_model <- fit(object = samples, model = object@model, data = data)

      target_dose_samples <- dose(
        mean(object@nextBest@target),
        model = object@model,
        samples = samples
      )

      additional_stats <- lapply(derive, function(f) f(target_dose_samples))

      list(
        data = data,
        dose = dose,
        fitTox = subset(fit_model, select = c(middle, lower, upper)),
        fit_biomarker = subset(
          fit_model,
          select = c(middleBiomarker, lowerBiomarker, upperBiomarker)
        ),
        rho_est = median(samples@data$rho),
        sigma2w_est = median(1 / samples@data$precW),
        stop = attr(should_stop, "message"),
        additional_stats = additional_stats,
        report_results = stopit_results
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "trueTox",
        "trueBiomarker",
        "covariance_matrix",
        "object",
        "mcmcOptions"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")
    recommended_doses <- as.numeric(sapply(result_list, "[[", "dose"))
    rho_estimates <- as.numeric(sapply(result_list, "[[", "rho_est"))
    sigma2w_estimates <- as.numeric(sapply(result_list, "[[", "sigma2w_est"))
    fit_tox_list <- lapply(result_list, "[[", "fitTox")
    fit_biomarker_list <- lapply(result_list, "[[", "fit_biomarker")
    stop_reasons <- lapply(result_list, "[[", "stop")
    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))
    additional_stats <- lapply(result_list, "[[", "additional_stats")

    DualSimulations(
      data = data_list,
      doses = recommended_doses,
      rho_est = rho_estimates,
      sigma2w_est = sigma2w_estimates,
      fit = fit_tox_list,
      fit_biomarker = fit_biomarker_list,
      stop_report = stop_report,
      stop_reasons = stop_reasons,
      additional_stats = additional_stats,
      seed = rng_state
    )
  }
)

## TDsamplesDesign ----

#' Simulate dose escalation procedure using DLE responses only with DLE samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a method to simulate dose escalation procedure only using the DLE responses.
#' This is a method based on the [`TDsamplesDesign`] where model used are of
#' [`ModelTox`] class object DLE samples are also used.
#'
#' @param object the [`TDsamplesDesign`] object we want to simulate the data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and returns the true probability
#'   (vector) of the occurrence of a DLE. Additional arguments can be supplied in `args`.
#' @param args (`data.frame`)\cr data frame with arguments for the `truth` function. The
#'   column names correspond to the argument names, the rows to the values of the
#'   arguments. The rows are appropriately recycled in the `nsim`
#'   simulations. In order to produce outcomes from the posterior predictive
#'   distribution, e.g, pass an `object` that contains the data observed so
#'   far, `truth` contains the `prob` function from the model in
#'   `object`, and `args` contains posterior samples from the model.
#' @param firstSeparate (`flag`)\cr enroll the first patient separately from the rest of
#'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
#'   in this patient.
#' @param mcmcOptions ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`PseudoSimulations`]
#'
#' @example examples/design-method-simulateTDsamplesDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "TDsamplesDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)
    assert_class(object, "TDsamplesDesign")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)

    # Keep original seed generation for snapshot test compatibility
    sim_seeds <- sample(x = seq_len(1e5), size = nsim)

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      truth_with_args <- function(dose) {
        do.call(truth, c(dose, current_args))
      }

      data <- object@data
      prob_placebo <- NULL

      if (data@placebo) {
        prob_placebo <- truth_with_args(object@data@doseGrid[1])
      }

      should_stop <- FALSE
      dose <- object@startingDose

      while (!should_stop) {
        prob <- truth_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        cohort_size_placebo <- NULL
        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        dlts <- if (firstSeparate && (cohort_size > 1L)) {
          first_dlt <- rbinom(n = 1L, size = 1L, prob = prob)

          dlts_placebo_first <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            dlts_placebo_first <- rbinom(n = 1L, size = 1L, prob = prob_placebo)
          }

          if (first_dlt == 0) {
            remaining_dlts <- rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = prob
            )
            c(first_dlt, remaining_dlts)
          } else {
            first_dlt
          }
        } else {
          rbinom(n = cohort_size, size = 1L, prob = prob)
        }

        dlts_placebo <- NULL
        if (data@placebo && (cohort_size_placebo > 0L)) {
          if (firstSeparate && (cohort_size > 1L) && length(dlts) == 1) {
            dlts_placebo <- dlts_placebo_first
          } else {
            dlts_placebo <- if (firstSeparate && (cohort_size > 1L)) {
              c(
                dlts_placebo_first,
                rbinom(
                  n = cohort_size_placebo,
                  size = 1L,
                  prob = prob_placebo
                )
              )
            } else {
              rbinom(n = cohort_size_placebo, size = 1L, prob = prob_placebo)
            }
          }
        }

        if (data@placebo && (cohort_size_placebo > 0L)) {
          data <- update(object = data, x = dose, y = dlts)
          data <- update(
            object = data,
            x = object@data@doseGrid[1],
            y = dlts_placebo,
            new_cohort = FALSE
          )
        } else {
          data <- update(object = data, x = dose, y = dlts)
        }

        model <- update(object@model, data = data)
        dose_limit <- maxDose(object@increments, data = data)
        samples <- mcmc(data = data, model = model, options = mcmcOptions)

        next_best_result <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = model,
          data = data,
          in_sim = TRUE
        )

        dose <- next_best_result$next_dose_drt
        td_target_during_trial <- next_best_result$dose_target_drt
        td_target_end_of_trial <- next_best_result$dose_target_eot
        td_target_end_of_trial_at_dose_grid <- next_best_result$next_dose_eot
        ci_tdeot <- list(
          lower = next_best_result$ci_dose_target_eot[1],
          upper = next_best_result$ci_dose_target_eot[2]
        )
        ratio_tdeot <- next_best_result$ci_ratio_dose_target_eot

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          samples = samples,
          model = model,
          data = data
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      fit_model <- fit(object = samples, model = model, data = data)

      list(
        data = data,
        dose = dose,
        TDtargetDuringTrial = td_target_during_trial,
        TDtargetEndOfTrial = td_target_end_of_trial,
        TDtargetEndOfTrialatdoseGrid = td_target_end_of_trial_at_dose_grid,
        TDtargetDuringTrialatdoseGrid = dose,
        CITDEOT = ci_tdeot,
        ratioTDEOT = ratio_tdeot,
        fit = subset(fit_model, select = c(middle, lower, upper)),
        stop = attr(should_stop, "message"),
        report_results = stopit_results
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "truth",
        "object",
        "mcmcOptions"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")

    td_target_during_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrial"
    ))

    td_target_end_of_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrial"
    ))

    td_target_during_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrialatdoseGrid"
    ))

    td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    recommended_doses <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    ci_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    fit_list <- lapply(result_list, "[[", "fit")
    stop_reasons <- lapply(result_list, "[[", "stop")

    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    PseudoSimulations(
      data = data_list,
      doses = recommended_doses,
      fit = fit_list,
      final_td_target_during_trial_estimates = td_target_during_trial_list,
      final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
      final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
      final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
      final_cis = ci_list,
      final_ratios = ratio_list,
      final_tdeot_cis = ci_tdeot_list,
      final_tdeot_ratios = ratio_tdeot_list,
      stop_reasons = stop_reasons,
      stop_report = stop_report,
      seed = rng_state
    )
  }
)

## TDDesign ----

#' Simulate dose escalation procedure using DLE responses only without samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a method to simulate dose escalation procedure only using the DLE responses.
#' This is a method based on the [`TDDesign`] where model used are of
#' [`ModelTox`] class object and no samples are involved.
#'
#' @param object the [`TDDesign`] object we want to simulate the data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and returns the true probability
#'   (vector) of the occurrence of a DLE. Additional arguments can be supplied in `args`.
#' @param args (`data.frame`)\cr data frame with arguments for the `truth` function. The
#'   column names correspond to the argument names, the rows to the values of the
#'   arguments. The rows are appropriately recycled in the `nsim`
#'   simulations. In order to produce outcomes from the posterior predictive
#'   distribution, e.g, pass an `object` that contains the data observed so
#'   far, `truth` contains the `prob` function from the model in
#'   `object`, and `args` contains posterior samples from the model.
#' @param firstSeparate (`flag`)\cr enroll the first patient separately from the rest of
#'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
#'   in this patient.
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`PseudoSimulations`]
#'
#' @example examples/design-method-simulateTDDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "TDDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    firstSeparate = FALSE,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)
    assert_class(object, "TDDesign")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)

    # Keep original seed generation for snapshot test compatibility
    sim_seeds <- sample(x = seq_len(1e5), size = nsim)

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      truth_with_args <- function(dose) {
        do.call(truth, c(dose, current_args))
      }

      data <- object@data
      prob_placebo <- NULL

      if (data@placebo) {
        prob_placebo <- truth_with_args(object@data@doseGrid[1])
      }

      should_stop <- FALSE
      dose <- object@startingDose

      while (!should_stop) {
        prob <- truth_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        cohort_size_placebo <- NULL
        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        dlts <- if (firstSeparate && (cohort_size > 1L)) {
          first_dlt <- rbinom(n = 1L, size = 1L, prob = prob)

          dlts_placebo_first <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            dlts_placebo_first <- rbinom(n = 1L, size = 1L, prob = prob_placebo)
          }

          if (first_dlt == 0) {
            remaining_dlts <- rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = prob
            )
            c(first_dlt, remaining_dlts)
          } else {
            first_dlt
          }
        } else {
          rbinom(n = cohort_size, size = 1L, prob = prob)
        }

        dlts_placebo <- NULL
        if (data@placebo && (cohort_size_placebo > 0L)) {
          if (firstSeparate && (cohort_size > 1L) && length(dlts) == 1) {
            dlts_placebo <- dlts_placebo_first
          } else {
            dlts_placebo <- rbinom(
              n = cohort_size_placebo,
              size = 1L,
              prob = prob_placebo
            )
          }
        }

        if (data@placebo && (cohort_size_placebo > 0L)) {
          data <- update(
            object = data,
            x = object@data@doseGrid[1],
            y = dlts_placebo
          )
          data <- update(
            object = data,
            x = dose,
            y = dlts,
            new_cohort = FALSE
          )
        } else {
          data <- update(object = data, x = dose, y = dlts)
        }

        model <- update(object@model, data = data)
        dose_limit <- maxDose(object@increments, data = data)

        next_best_result <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          model = model,
          data = data,
          in_sim = TRUE
        )

        dose <- next_best_result$next_dose_drt
        td_target_during_trial <- next_best_result$dose_target_drt
        td_target_end_of_trial <- next_best_result$dose_target_eot
        td_target_end_of_trial_at_dose_grid <- next_best_result$next_dose_eot
        ci_tdeot <- list(
          lower = next_best_result$ci_dose_target_eot[1],
          upper = next_best_result$ci_dose_target_eot[2]
        )
        ratio_tdeot <- next_best_result$ci_ratio_dose_target_eot

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          model = model,
          data = data
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      prob_fun <- probFunction(
        model,
        phi1 = model@phi1,
        phi2 = model@phi2
      )
      fit_model <- list(
        phi1 = model@phi1,
        phi2 = model@phi2,
        probDLE = prob_fun(object@data@doseGrid)
      )

      list(
        data = data,
        dose = dose,
        TDtargetDuringTrial = td_target_during_trial,
        TDtargetEndOfTrial = td_target_end_of_trial,
        TDtargetEndOfTrialatdoseGrid = td_target_end_of_trial_at_dose_grid,
        TDtargetDuringTrialatdoseGrid = dose,
        CITDEOT = ci_tdeot,
        ratioTDEOT = ratio_tdeot,
        fit = fit_model,
        stop = attr(should_stop, "message"),
        report_results = stopit_results
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "truth",
        "object"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")

    td_target_during_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrial"
    ))

    td_target_end_of_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrial"
    ))

    td_target_during_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrialatdoseGrid"
    ))

    td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    recommended_doses <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    ci_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    fit_list <- lapply(result_list, "[[", "fit")
    stop_reasons <- lapply(result_list, "[[", "stop")

    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    PseudoSimulations(
      data = data_list,
      doses = recommended_doses,
      fit = fit_list,
      final_td_target_during_trial_estimates = td_target_during_trial_list,
      final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
      final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
      final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
      final_cis = ci_list,
      final_ratios = ratio_list,
      final_tdeot_cis = ci_tdeot_list,
      final_tdeot_ratios = ratio_tdeot_list,
      stop_reasons = stop_reasons,
      stop_report = stop_report,
      seed = rng_state
    )
  }
)

## DualResponsesDesign ----

#' Simulate dose escalation procedure using both DLE and efficacy responses without samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a method to simulate dose escalation procedure using both DLE and efficacy responses.
#' This is a method based on the [`DualResponsesDesign`] where DLE model used are of
#' [`ModelTox`] class object and efficacy model used are of [`ModelEff`]
#' class object. In addition, no DLE and efficacy samples are involved or generated in the simulation
#' process.
#'
#' @param object the [`DualResponsesDesign`] object we want to simulate the data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param trueDLE (`function`)\cr a function which takes as input a dose (vector) and returns the true probability
#'   (vector) of the occurrence of a DLE. Additional arguments can be supplied in `args`.
#' @param trueEff (`function`)\cr a function which takes as input a dose (vector) and returns the expected efficacy
#'   responses (vector). Additional arguments can be supplied in `args`.
#' @param trueNu (`number`)\cr the precision, the inverse of the variance of the efficacy responses
#' @param args (`data.frame`)\cr data frame with arguments for the `trueDLE` and
#'   `trueEff` function. The column names correspond to the argument
#'   names, the rows to the values of the arguments. The rows are appropriately
#'   recycled in the `nsim` simulations.
#' @param firstSeparate (`flag`)\cr enroll the first patient separately from the rest of
#'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
#'   in this patient.
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`PseudoDualSimulations`]
#'
#' @example examples/design-method-simulateDualResponsesDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "DualResponsesDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    trueDLE,
    trueEff,
    trueNu,
    args = NULL,
    firstSeparate = FALSE,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(trueDLE)
    assert_function(trueEff)
    assert_true(trueNu > 0)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)
    assert_class(object, "DualResponsesDesign")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)

    dle_arg_names <- names(formals(trueDLE))[-1]
    eff_arg_names <- names(formals(trueEff))[-1]

    rng_state <- set_seed(seed)

    # Keep original seed generation for snapshot test compatibility
    sim_seeds <- sample(x = seq_len(1e5), size = nsim)

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      dle_with_args <- function(dose) {
        do.call(
          trueDLE,
          c(dose, as.list(current_args)[dle_arg_names])
        )
      }

      eff_with_args <- function(dose) {
        do.call(
          trueEff,
          c(dose, as.list(current_args)[eff_arg_names])
        )
      }

      data <- object@data
      sigma2 <- 1 / trueNu
      prob_placebo <- NULL
      mean_eff_placebo <- NULL

      if (data@placebo) {
        prob_placebo <- dle_with_args(object@data@doseGrid[1])
        mean_eff_placebo <- eff_with_args(object@data@doseGrid[1])
      }

      should_stop <- FALSE
      dose <- object@startingDose

      while (!should_stop) {
        prob <- dle_with_args(dose)
        mean_eff <- eff_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        cohort_size_placebo <- NULL
        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        if (firstSeparate && (cohort_size > 1L)) {
          dlts <- rbinom(n = 1L, size = 1L, prob = prob)
          eff_responses <- rnorm(n = 1L, mean = mean_eff, sd = sqrt(sigma2))

          dlts_placebo <- NULL
          eff_responses_placebo <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            dlts_placebo <- rbinom(n = 1L, size = 1L, prob = prob_placebo)
            eff_responses_placebo <- rnorm(
              n = 1L,
              mean = mean_eff_placebo,
              sd = sqrt(sigma2)
            )
          }

          if (dlts == 0) {
            remaining_dlts <- rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = prob
            )
            remaining_eff <- rnorm(
              n = cohort_size - 1L,
              mean = mean_eff,
              sd = sqrt(sigma2)
            )
            dlts <- c(dlts, remaining_dlts)
            eff_responses <- c(eff_responses, remaining_eff)

            if (data@placebo && (cohort_size_placebo > 0L)) {
              remaining_dlts_placebo <- rbinom(
                n = cohort_size_placebo,
                size = 1L,
                prob = prob_placebo
              )
              remaining_eff_placebo <- rnorm(
                n = cohort_size_placebo,
                mean = mean_eff_placebo,
                sd = sqrt(sigma2)
              )
              dlts_placebo <- c(dlts_placebo, remaining_dlts_placebo)
              eff_responses_placebo <- c(
                eff_responses_placebo,
                remaining_eff_placebo
              )
            }
          }
        } else {
          dlts <- rbinom(n = cohort_size, size = 1L, prob = prob)
          eff_responses <- rnorm(
            n = cohort_size,
            mean = mean_eff,
            sd = sqrt(sigma2)
          )

          dlts_placebo <- NULL
          eff_responses_placebo <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            dlts_placebo <- rbinom(
              n = cohort_size_placebo,
              size = 1L,
              prob = prob_placebo
            )
            eff_responses_placebo <- rnorm(
              n = cohort_size_placebo,
              mean = mean_eff_placebo,
              sd = sqrt(sigma2)
            )
          }
        }

        if (data@placebo && (cohort_size_placebo > 0L)) {
          data <- update(
            object = data,
            x = object@data@doseGrid[1],
            y = dlts_placebo,
            w = eff_responses_placebo,
            check = FALSE
          )
          data <- update(
            object = data,
            x = dose,
            y = dlts,
            w = eff_responses,
            new_cohort = FALSE
          )
        } else {
          data <- update(object = data, x = dose, y = dlts, w = eff_responses)
        }

        dle_model <- update(object = object@model, data = data)
        eff_model <- update(object = object@eff_model, data = data)

        eff_nu <- eff_model@nu
        eff_sigma2 <- if (eff_model@use_fixed) {
          1 / eff_nu
        } else {
          1 / (as.numeric(eff_nu["a"] / eff_nu["b"]))
        }

        dose_limit <- maxDose(object@increments, data = data)

        next_best_result <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          model = dle_model,
          data = data,
          model_eff = eff_model,
          in_sim = TRUE
        )

        dose <- next_best_result$next_dose
        td_target_during_trial <- next_best_result$dose_target_drt
        td_target_during_trial_at_dose_grid <- next_best_result$next_dose_drt
        td_target_end_of_trial <- next_best_result$dose_target_eot
        td_target_end_of_trial_at_dose_grid <- next_best_result$next_dose_eot
        gstar <- next_best_result$dose_max_gain
        gstar_at_dose_grid <- next_best_result$next_dose_max_gain

        recommend <- min(
          td_target_end_of_trial_at_dose_grid,
          gstar_at_dose_grid
        )

        ci_tdeot <- list(
          lower = next_best_result$ci_dose_target_eot[1],
          upper = next_best_result$ci_dose_target_eot[2]
        )
        ratio_tdeot <- next_best_result$ci_ratio_dose_target_eot

        ci_gstar <- list(
          lower = next_best_result$ci_dose_max_gain[1],
          upper = next_best_result$ci_dose_max_gain[2]
        )
        ratio_gstar <- next_best_result$ci_ratio_dose_max_gain

        optimal_dose <- min(gstar, td_target_end_of_trial)

        if (optimal_dose == gstar) {
          ratio <- ratio_gstar
          ci <- ci_gstar
        } else {
          ratio <- ratio_tdeot
          ci <- ci_tdeot
        }

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          model = dle_model,
          data = data,
          Effmodel = eff_model
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      prob_fun <- probFunction(
        dle_model,
        phi1 = dle_model@phi1,
        phi2 = dle_model@phi2
      )
      dle_fit <- list(
        phi1 = dle_model@phi1,
        phi2 = dle_model@phi2,
        probDLE = prob_fun(object@data@doseGrid)
      )

      eff_fun <- efficacyFunction(
        eff_model,
        theta1 = eff_model@theta1,
        theta2 = eff_model@theta2
      )
      eff_fit <- list(
        theta1 = eff_model@theta1,
        theta2 = eff_model@theta2,
        ExpEff = eff_fun(object@data@doseGrid)
      )

      list(
        data = data,
        dose = dose,
        TDtargetDuringTrial = td_target_during_trial,
        TDtargetDuringTrialAtDoseGrid = td_target_during_trial_at_dose_grid,
        TDtargetEndOfTrial = td_target_end_of_trial,
        TDtargetEndOfTrialAtDoseGrid = td_target_end_of_trial_at_dose_grid,
        Gstar = gstar,
        GstarAtDoseGrid = gstar_at_dose_grid,
        Recommend = recommend,
        OptimalDose = optimal_dose,
        OptimalDoseAtDoseGrid = recommend,
        ratio = ratio,
        CI = ci,
        ratioGstar = ratio_gstar,
        CIGstar = ci_gstar,
        ratioTDEOT = ratio_tdeot,
        CITDEOT = ci_tdeot,
        fitDLE = dle_fit,
        fitEff = eff_fit,
        sigma2est = eff_sigma2,
        stop = attr(should_stop, "message"),
        report_results = stopit_results
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "trueDLE",
        "trueEff",
        "trueNu",
        "object"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")
    recommended_doses <- as.numeric(sapply(result_list, "[[", "Recommend"))

    td_target_during_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrial"
    ))

    td_target_end_of_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrial"
    ))

    td_target_during_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrialAtDoseGrid"
    ))

    td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialAtDoseGrid"
    ))

    gstar_list <- as.numeric(sapply(result_list, "[[", "Gstar"))
    gstar_at_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "GstarAtDoseGrid"
    ))

    optimal_dose_list <- as.numeric(sapply(result_list, "[[", "OptimalDose"))
    optimal_dose_at_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "Recommend"
    ))

    ci_list <- lapply(result_list, "[[", "CI")
    ratio_list <- as.numeric(sapply(result_list, "[[", "ratio"))
    ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    ci_gstar_list <- lapply(result_list, "[[", "CIGstar")
    ratio_gstar_list <- as.numeric(sapply(result_list, "[[", "ratioGstar"))

    fit_dle_list <- lapply(result_list, "[[", "fitDLE")
    fit_eff_list <- lapply(result_list, "[[", "fitEff")
    sigma2_estimates <- as.numeric(sapply(result_list, "[[", "sigma2est"))
    stop_reasons <- lapply(result_list, "[[", "stop")

    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    PseudoDualSimulations(
      data = data_list,
      doses = recommended_doses,
      final_td_target_during_trial_estimates = td_target_during_trial_list,
      final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
      final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
      final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
      final_cis = ci_list,
      final_ratios = ratio_list,
      final_gstar_estimates = gstar_list,
      final_gstar_at_dose_grid = gstar_at_dose_grid_list,
      final_gstar_cis = ci_gstar_list,
      final_gstar_ratios = ratio_gstar_list,
      final_tdeot_cis = ci_tdeot_list,
      final_tdeot_ratios = ratio_tdeot_list,
      final_optimal_dose = optimal_dose_list,
      final_optimal_dose_at_dose_grid = optimal_dose_at_dose_grid_list,
      fit = fit_dle_list,
      fit_eff = fit_eff_list,
      sigma2_est = sigma2_estimates,
      stop_reasons = stop_reasons,
      stop_report = stop_report,
      seed = rng_state
    )
  }
)

## DualResponsesSamplesDesign ----

### h_simulate_flexi ----

h_simulate_flexi <- function(
  object,
  nsim = 1L,
  seed = NULL,
  trueDLE,
  trueEff,
  trueNu = NULL,
  trueSigma2 = NULL,
  trueSigma2betaW = NULL,
  args = NULL,
  firstSeparate = FALSE,
  mcmcOptions = McmcOptions(),
  parallel = FALSE,
  nCores = min(parallel::detectCores(), 5L),
  ...
) {
  stopifnot(
    trueSigma2 > 0,
    trueSigma2betaW > 0,
    is.numeric(trueEff),
    length(trueEff) == length(object@data@doseGrid)
  )

  args <- as.data.frame(args)
  n_args <- max(nrow(args), 1L)

  # Get argument names (excluding the first one which is the dose)
  dle_arg_names <- names(formals(trueDLE))[-1]

  # Seed handling
  rng_state <- set_seed(seed)

  # Generate individual seeds for simulation runs
  sim_seeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

  # Function to run a single simulation with index "iter_sim"
  run_sim <- function(iter_sim) {
    # Set the seed for this run
    set.seed(sim_seeds[iter_sim])

    # Get current arguments (appropriately recycled)
    current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

    # DLE truth function with current arguments
    dle_with_args <- function(dose) {
      do.call(
        trueDLE,
        # First argument: the dose
        c(
          dose,
          # Following arguments
          current_args
        )
      )
    }

    # Efficacy truth function (fixed for EffFlexi)
    eff_truth <- trueEff

    # Start with the provided data
    data <- object@data

    # Trial control variables
    should_stop <- FALSE
    dose <- object@startingDose
    dose_pl <- object@data@doseGrid[1]

    # Start with specified variance parameters
    sigma2 <- trueSigma2
    sigma2_beta_w <- trueSigma2betaW

    # Main simulation loop
    while (!should_stop) {
      # Calculate probabilities and outcomes at current dose
      dle_prob <- dle_with_args(dose)
      dle_prob_pl <- dle_with_args(dose_pl)

      dose_index <- which(dose == data@doseGrid)
      mean_eff <- eff_truth[dose_index]
      mean_eff_pl <- eff_truth[1]

      # Determine cohort size
      cohort_size <- size(object@cohort_size, dose = dose, data = data)

      if (data@placebo) {
        placebo_size <- size(
          object@pl_cohort_size,
          dose = dose,
          data = data
        )
      }

      ## simulate DLTs: depends on whether we
      ## separate the first patient or not.
      if (firstSeparate && (cohort_size > 1L)) {
        ## dose the first patient
        dlts <- rbinom(
          n = 1L,
          size = 1L,
          prob = dle_prob
        )

        if (data@placebo && (placebo_size > 0L)) {
          dlts_pl <- rbinom(
            n = 1L,
            size = 1L,
            prob = dle_prob_pl
          )
        }

        eff_responses <- rnorm(
          n = 1L,
          mean = mean_eff,
          sd = sqrt(trueSigma2)
        )

        if (data@placebo && (placebo_size > 0L)) {
          eff_responses_pl <- rnorm(
            n = 1L,
            mean = mean_eff_pl,
            sd = sqrt(trueSigma2)
          )
        }

        # If no DLT in first patient, enroll remaining patients
        if (dlts == 0) {
          dlts <- c(
            dlts,
            rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = dle_prob
            )
          )
          eff_responses <- c(
            eff_responses,
            rnorm(
              n = cohort_size - 1L,
              mean = mean_eff,
              sd = sqrt(trueSigma2)
            )
          )
          if (data@placebo && (placebo_size > 0L)) {
            dlts_pl <- c(
              dlts_pl,
              rbinom(
                n = placebo_size,
                size = 1L,
                prob = dle_prob_pl
              )
            )
            eff_responses_pl <- c(
              eff_responses_pl,
              rnorm(
                n = placebo_size,
                mean = mean_eff_pl,
                sd = sqrt(trueSigma2)
              )
            )
          }
        }
      } else {
        # Dose all patients directly
        dlts <- rbinom(
          n = cohort_size,
          size = 1L,
          prob = dle_prob
        )

        eff_responses <- rnorm(
          n = cohort_size,
          mean = mean_eff,
          sd = sqrt(trueSigma2)
        )
        if (data@placebo && (placebo_size > 0L)) {
          dlts_pl <- rbinom(
            n = placebo_size,
            size = 1L,
            prob = dle_prob_pl
          )
          eff_responses_pl <- rnorm(
            n = placebo_size,
            mean = mean_eff_pl,
            sd = sqrt(trueSigma2)
          )
        }
      }

      ## update the data with this placebo (if any) cohort and then with active dose
      if (data@placebo && (placebo_size > 0L)) {
        data <- update(
          object = data,
          x = object@data@doseGrid[1],
          y = dlts_pl,
          w = eff_responses_pl,
          check = FALSE
        )

        ## update the data with active dose
        data <- update(
          object = data,
          x = dose,
          y = dlts,
          w = eff_responses,
          new_cohort = FALSE
        )
      } else {
        ## update the data with this cohort
        data <- update(
          object = data,
          x = dose,
          y = dlts,
          w = eff_responses
        )
      }

      # Update models with new data
      dle_model <- update(
        object = object@model,
        data = data
      )

      eff_model <- update(
        object = object@eff_model,
        data = data
      )

      # Calculate dose limit
      dose_limit <- maxDose(object@increments, data = data)

      # Generate MCMC samples from both models
      dle_samples <- mcmc(
        data = data,
        model = dle_model,
        options = mcmcOptions
      )

      eff_samples <- mcmc(
        data = data,
        model = eff_model,
        options = mcmcOptions
      )

      # Update variance estimates from MCMC samples
      sigma2 <- mean(eff_samples@data$sigma2W)
      sigma2_beta_w <- mean(eff_samples@data$sigma2betaW)

      # Calculate next best dose
      next_bd <- nextBest(
        object@nextBest,
        doselimit = dose_limit,
        samples = dle_samples,
        model = dle_model,
        model_eff = eff_model,
        samples_eff = eff_samples,
        data = data,
        in_sim = TRUE
      )

      # Extract dose recommendations
      dose <- next_bd$next_dose
      td_target_during_trial <- next_bd$dose_target_drt
      td_target_during_trial_at_dose_grid <- next_bd$next_dose_drt
      td_target_end_of_trial <- next_bd$dose_target_eot
      td_target_end_of_trial_at_dose_grid <- next_bd$next_dose_eot
      gstar <- next_bd$dose_max_gain
      gstar_at_dose_grid <- next_bd$next_dose_max_gain

      recommend <- min(
        td_target_end_of_trial_at_dose_grid,
        gstar_at_dose_grid
      )

      # Calculate 95% confidence intervals and ratios
      ci_tdeot <- list(
        lower = next_bd$ci_dose_target_eot[1],
        upper = next_bd$ci_dose_target_eot[2]
      )
      ratio_tdeot <- next_bd$ci_ratio_dose_target_eot

      ci_gstar <- list(
        lower = next_bd$ci_dose_max_gain[1],
        upper = next_bd$ci_dose_max_gain[2]
      )
      ratio_gstar <- next_bd$ci_ratio_dose_max_gain

      # Find the optimal dose
      optimal_dose <- min(gstar, td_target_end_of_trial)

      if (optimal_dose == gstar) {
        ratio <- ratio_gstar
        ci <- ci_gstar
      } else {
        ratio <- ratio_tdeot
        ci <- ci_tdeot
      }

      # Evaluate stopping rules
      should_stop <- stopTrial(
        object@stopping,
        dose = dose,
        samples = dle_samples,
        model = dle_model,
        data = data,
        TDderive = object@nextBest@derive,
        Effmodel = eff_model,
        Effsamples = eff_samples,
        Gstarderive = object@nextBest@mg_derive
      )
      stop_results <- h_unpack_stopit(should_stop)
    }

    # Calculate final model fits
    dle_fit <- fit(
      object = dle_samples,
      model = dle_model,
      data = data
    )

    eff_fit <- fit(
      object = eff_samples,
      model = eff_model,
      data = data
    )

    # Return simulation results
    list(
      data = data,
      dose = dose,
      TDtargetDuringTrial = td_target_during_trial,
      TDtargetDuringTrialAtDoseGrid = td_target_during_trial_at_dose_grid,
      TDtargetEndOfTrial = td_target_end_of_trial,
      TDtargetEndOfTrialAtDoseGrid = td_target_end_of_trial_at_dose_grid,
      Gstar = gstar,
      GstarAtDoseGrid = gstar_at_dose_grid,
      Recommend = recommend,
      OptimalDose = optimal_dose,
      OptimalDoseAtDoseGrid = recommend,
      ratio = ratio,
      CI = ci,
      ratioGstar = ratio_gstar,
      CIGstar = ci_gstar,
      ratioTDEOT = ratio_tdeot,
      CITDEOT = ci_tdeot,
      fitDLE = subset(dle_fit, select = c(middle, lower, upper)),
      fitEff = subset(eff_fit, select = c(middle, lower, upper)),
      sigma2est = sigma2,
      sigma2betaWest = sigma2_beta_w,
      stop = attr(should_stop, "message"),
      report_results = stop_results
    )
  }

  result_list <- get_result_list(
    fun = run_sim,
    nsim = nsim,
    vars = c(
      "sim_seeds",
      "args",
      "n_args",
      "firstSeparate",
      "trueDLE",
      "trueEff",
      "trueSigma2",
      "trueSigma2betaW",
      "object",
      "mcmcOptions"
    ),
    parallel = parallel,
    n_cores = nCores
  )

  # Process simulation results
  data_list <- lapply(result_list, "[[", "data")
  recommended_doses <- as.numeric(sapply(result_list, "[[", "Recommend"))

  # Extract model fits and variance estimates
  fit_dle_list <- lapply(result_list, "[[", "fitDLE")
  fit_eff_list <- lapply(result_list, "[[", "fitEff")
  sigma2_estimates <- as.numeric(sapply(result_list, "[[", "sigma2est"))
  sigma2_beta_w_estimates <- as.numeric(sapply(
    result_list,
    "[[",
    "sigma2betaWest"
  ))

  # Extract TD target estimates
  td_target_during_trial_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetDuringTrial"
  ))

  td_target_end_of_trial_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetEndOfTrial"
  ))

  td_target_during_trial_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetDuringTrialAtDoseGrid"
  ))

  td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetEndOfTrialAtDoseGrid"
  ))

  # Extract Gstar and optimal dose estimates
  gstar_list <- as.numeric(sapply(result_list, "[[", "Gstar"))

  gstar_at_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "GstarAtDoseGrid"
  ))

  optimal_dose_list <- as.numeric(sapply(result_list, "[[", "OptimalDose"))

  optimal_dose_at_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "Recommend"
  ))

  # Extract confidence intervals and ratios
  ci_list <- lapply(result_list, "[[", "CI")

  ratio_list <- as.numeric(sapply(result_list, "[[", "ratio"))

  ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")

  ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))

  ci_gstar_list <- lapply(result_list, "[[", "CIGstar")

  ratio_gstar_list <- as.numeric(sapply(result_list, "[[", "ratioGstar"))

  # Extract stopping information
  stop_reasons <- lapply(result_list, "[[", "stop")

  stop_results <- lapply(result_list, "[[", "report_results")
  stop_report <- as.matrix(do.call(rbind, stop_results))

  # Return simulation results
  PseudoDualFlexiSimulations(
    data = data_list,
    doses = recommended_doses,
    final_td_target_during_trial_estimates = td_target_during_trial_list,
    final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
    final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
    final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
    final_cis = ci_list,
    final_ratios = ratio_list,
    final_gstar_estimates = gstar_list,
    final_gstar_at_dose_grid = gstar_at_dose_grid_list,
    final_gstar_cis = ci_gstar_list,
    final_gstar_ratios = ratio_gstar_list,
    final_tdeot_cis = ci_tdeot_list,
    final_tdeot_ratios = ratio_tdeot_list,
    final_optimal_dose = optimal_dose_list,
    final_optimal_dose_at_dose_grid = optimal_dose_at_dose_grid_list,
    fit = fit_dle_list,
    fit_eff = fit_eff_list,
    sigma2_est = sigma2_estimates,
    sigma2_beta_w_est = sigma2_beta_w_estimates,
    stop_reasons = stop_reasons,
    stop_report = stop_report,
    seed = rng_state
  )
}

### h_simulate_nonflexi ----

h_simulate_nonflexi <- function(
  object,
  nsim = 1L,
  seed = NULL,
  trueDLE,
  trueEff,
  trueNu = NULL,
  trueSigma2 = NULL,
  trueSigma2betaW = NULL,
  args = NULL,
  firstSeparate = FALSE,
  mcmcOptions = McmcOptions(),
  parallel = FALSE,
  nCores = min(parallel::detectCores(), 5L),
  ...
) {
  stopifnot(
    trueNu > 0,
    is.function(trueEff)
  )

  args <- as.data.frame(args)
  n_args <- max(nrow(args), 1L)

  # Get argument names (excluding the first one which is the dose)
  dle_arg_names <- names(formals(trueDLE))[-1]
  eff_arg_names <- names(formals(trueEff))[-1]

  # Seed handling
  rng_state <- set_seed(seed)

  # Generate individual seeds for simulation runs
  sim_seeds <- sample(x = seq_len(1e5), size = nsim)

  # Function to run a single simulation with index "iter_sim"
  run_sim <- function(iter_sim) {
    # Set the seed for this run
    set.seed(sim_seeds[iter_sim])

    # Get current arguments (appropriately recycled)
    current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

    # DLE truth function with current arguments
    dle_with_args <- function(dose) {
      do.call(
        trueDLE,
        # First argument: the dose
        c(
          dose,
          # Following arguments: take only those that
          # are required by the DLE function
          as.list(current_args)[dle_arg_names]
        )
      )
    }

    # Efficacy truth function with current arguments
    eff_with_args <- function(dose) {
      do.call(
        trueEff,
        # First argument: the dose
        c(
          dose,
          # Following arguments: take only those that
          # are required by the Eff function
          as.list(current_args)[eff_arg_names]
        )
      )
    }

    # Find true sigma2 to generate responses
    true_sigma2 <- 1 / trueNu

    # Start with the provided data
    data <- object@data

    # Trial control variables
    should_stop <- FALSE
    dose <- object@startingDose

    # Main simulation loop
    while (!should_stop) {
      # Calculate probabilities and outcomes at current dose
      dle_prob <- dle_with_args(dose)
      mean_eff <- eff_with_args(dose)

      # Determine cohort size
      cohort_size <- size(object@cohort_size, dose = dose, data = data)

      if (data@placebo) {
        placebo_size <- size(
          object@pl_cohort_size,
          dose = dose,
          data = data
        )
        dose_pl <- data@doseGrid[1]
        dle_prob_pl <- dle_with_args(dose_pl)
        mean_eff_pl <- eff_with_args(dose_pl)
      }

      ## simulate DLTs: depends on whether we
      ## separate the first patient or not.
      if (firstSeparate && (cohort_size > 1L)) {
        # Dose the first patient
        dlts <- rbinom(
          n = 1L,
          size = 1L,
          prob = dle_prob
        )

        if (data@placebo && (placebo_size > 0L)) {
          dlts_pl <- rbinom(
            n = 1L,
            size = 1L,
            prob = dle_prob_pl
          )
        }

        eff_responses <- rnorm(
          n = 1L,
          mean = mean_eff,
          sd = sqrt(true_sigma2)
        )

        if (data@placebo && (placebo_size > 0L)) {
          eff_responses_pl <- rnorm(
            n = 1L,
            mean = mean_eff_pl,
            sd = sqrt(true_sigma2)
          )
        }

        # If there is no DLT, enroll the remaining patients
        if (dlts == 0) {
          dlts <- c(
            dlts,
            rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = dle_prob
            )
          )
          eff_responses <- c(
            eff_responses,
            rnorm(
              n = cohort_size - 1L,
              mean = mean_eff,
              sd = sqrt(true_sigma2)
            )
          )

          if (data@placebo && (placebo_size > 0L)) {
            dlts_pl <- c(
              dlts_pl,
              rbinom(
                n = placebo_size,
                size = 1L,
                prob = dle_prob_pl
              )
            )
            eff_responses_pl <- c(
              mean_eff_pl,
              rnorm(
                n = placebo_size,
                mean = mean_eff_pl,
                sd = sqrt(true_sigma2)
              )
            )
          }
        }
      } else {
        # Directly dose all patients
        dlts <- rbinom(
          n = cohort_size,
          size = 1L,
          prob = dle_prob
        )
        eff_responses <- rnorm(
          n = cohort_size,
          mean = mean_eff,
          sd = sqrt(true_sigma2)
        )

        if (data@placebo && (placebo_size > 0L)) {
          dlts_pl <- rbinom(
            n = placebo_size,
            size = 1L,
            prob = dle_prob_pl
          )
          eff_responses_pl <- rnorm(
            n = placebo_size,
            mean = mean_eff_pl,
            sd = sqrt(true_sigma2)
          )
        }
      }

      ## update the data with this placebo (if any) cohort and then with active dose
      if (data@placebo && (placebo_size > 0L)) {
        data <- update(
          object = data,
          x = object@data@doseGrid[1],
          y = dlts_pl,
          w = eff_responses_pl,
          check = FALSE
        )

        # Update the data with active dose
        data <- update(
          object = data,
          x = dose,
          y = dlts,
          w = eff_responses,
          new_cohort = FALSE
        )
      } else {
        # Update the data with this cohort
        data <- update(
          object = data,
          x = dose,
          y = dlts,
          w = eff_responses
        )
      }

      # Update models with new data
      dle_model <- update(
        object = object@model,
        data = data
      )

      eff_model <- update(
        object = object@eff_model,
        data = data
      )

      nu <- eff_model@nu

      dle_samples <- mcmc(
        data = data,
        model = dle_model,
        options = mcmcOptions
      )

      eff_samples <- mcmc(
        data = data,
        model = eff_model,
        options = mcmcOptions
      )

      sigma2 <- if (eff_model@use_fixed) {
        1 / nu
      } else {
        1 / (as.numeric(nu["a"] / nu["b"]))
      }

      # Calculate dose limit
      dose_limit <- maxDose(object@increments, data = data)

      # Calculate next best dose
      next_bd <- nextBest(
        object@nextBest,
        doselimit = dose_limit,
        samples = dle_samples,
        model = dle_model,
        data = data,
        model_eff = eff_model,
        samples_eff = eff_samples,
        in_sim = TRUE
      )

      # Extract dose recommendations
      dose <- next_bd$next_dose
      td_target_during_trial <- next_bd$dose_target_drt
      td_target_during_trial_at_dose_grid <- next_bd$next_dose_drt
      td_target_end_of_trial <- next_bd$dose_target_eot
      td_target_end_of_trial_at_dose_grid <- next_bd$next_dose_eot
      gstar <- next_bd$dose_max_gain
      gstar_at_dose_grid <- next_bd$next_dose_max_gain

      recommend <- min(
        td_target_end_of_trial_at_dose_grid,
        gstar_at_dose_grid
      )

      # Calculate 95% confidence intervals and ratios
      ci_tdeot <- list(
        lower = next_bd$ci_dose_target_eot[1],
        upper = next_bd$ci_dose_target_eot[2]
      )
      ratio_tdeot <- next_bd$ci_ratio_dose_target_eot

      ci_gstar <- list(
        lower = next_bd$ci_dose_max_gain[1],
        upper = next_bd$ci_dose_max_gain[2]
      )
      ratio_gstar <- next_bd$ci_ratio_dose_max_gain

      # Find the optimal dose
      optimal_dose <- min(gstar, td_target_end_of_trial)

      if (optimal_dose == gstar) {
        ratio <- ratio_gstar
        ci <- ci_gstar
      } else {
        ratio <- ratio_tdeot
        ci <- ci_tdeot
      }

      # Evaluate stopping rules
      should_stop <- stopTrial(
        object@stopping,
        dose = dose,
        samples = dle_samples,
        model = dle_model,
        data = data,
        TDderive = object@nextBest@derive,
        Effmodel = eff_model,
        Effsamples = eff_samples,
        Gstarderive = object@nextBest@mg_derive
      )
      stop_results <- h_unpack_stopit(should_stop)
    }
    # Calculate final model fits
    dle_fit <- fit(
      object = dle_samples,
      model = dle_model,
      data = data
    )

    eff_fit <- fit(
      object = eff_samples,
      model = eff_model,
      data = data
    )

    # Return simulation results
    list(
      data = data,
      dose = dose,
      TDtargetDuringTrial = td_target_during_trial,
      TDtargetDuringTrialAtDoseGrid = td_target_during_trial_at_dose_grid,
      TDtargetEndOfTrial = td_target_end_of_trial,
      TDtargetEndOfTrialAtDoseGrid = td_target_end_of_trial_at_dose_grid,
      Gstar = gstar,
      GstarAtDoseGrid = gstar_at_dose_grid,
      Recommend = recommend,
      OptimalDose = optimal_dose,
      OptimalDoseAtDoseGrid = recommend,
      ratio = ratio,
      CI = ci,
      ratioGstar = ratio_gstar,
      CIGstar = ci_gstar,
      ratioTDEOT = ratio_tdeot,
      CITDEOT = ci_tdeot,
      fitDLE = subset(dle_fit, select = c(middle, lower, upper)),
      fitEff = subset(eff_fit, select = c(middle, lower, upper)),
      sigma2est = sigma2,
      stop = attr(
        should_stop,
        "message"
      ),
      report_results = stop_results
    )
  }

  result_list <- get_result_list(
    fun = run_sim,
    nsim = nsim,
    vars = c(
      "sim_seeds",
      "args",
      "n_args",
      "firstSeparate",
      "trueDLE",
      "trueEff",
      "trueNu",
      "object"
    ),
    parallel = parallel,
    n_cores = nCores
  )

  # Process simulation results
  data_list <- lapply(result_list, "[[", "data")
  recommended_doses <- as.numeric(sapply(result_list, "[[", "Recommend"))

  # Extract TD target estimates
  td_target_during_trial_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetDuringTrial"
  ))

  td_target_end_of_trial_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetEndOfTrial"
  ))

  td_target_during_trial_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetDuringTrialAtDoseGrid"
  ))

  td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetEndOfTrialAtDoseGrid"
  ))

  # Extract Gstar and optimal dose estimates
  gstar_list <- as.numeric(sapply(result_list, "[[", "Gstar"))

  gstar_at_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "GstarAtDoseGrid"
  ))

  optimal_dose_list <- as.numeric(sapply(result_list, "[[", "OptimalDose"))

  optimal_dose_at_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "Recommend"
  ))

  # Extract confidence intervals and ratios
  ci_list <- lapply(result_list, "[[", "CI")
  ratio_list <- as.numeric(sapply(result_list, "[[", "ratio"))

  ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")
  ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))

  ci_gstar_list <- lapply(result_list, "[[", "CIGstar")
  ratio_gstar_list <- as.numeric(sapply(result_list, "[[", "ratioGstar"))

  # Extract model fits and variance estimates
  fit_dle_list <- lapply(result_list, "[[", "fitDLE")
  fit_eff_list <- lapply(result_list, "[[", "fitEff")
  sigma2_estimates <- as.numeric(sapply(result_list, "[[", "sigma2est"))

  # Extract stopping information
  stop_reasons <- lapply(result_list, "[[", "stop")

  stop_results <- lapply(result_list, "[[", "report_results")
  stop_report <- as.matrix(do.call(rbind, stop_results))

  # Return simulation results
  PseudoDualSimulations(
    data = data_list,
    doses = recommended_doses,
    final_td_target_during_trial_estimates = td_target_during_trial_list,
    final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
    final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
    final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
    final_cis = ci_list,
    final_ratios = ratio_list,
    final_gstar_estimates = gstar_list,
    final_gstar_at_dose_grid = gstar_at_dose_grid_list,
    final_gstar_cis = ci_gstar_list,
    final_gstar_ratios = ratio_gstar_list,
    final_tdeot_cis = ci_tdeot_list,
    final_tdeot_ratios = ratio_tdeot_list,
    final_optimal_dose = optimal_dose_list,
    final_optimal_dose_at_dose_grid = optimal_dose_at_dose_grid_list,
    fit = fit_dle_list,
    fit_eff = fit_eff_list,
    sigma2_est = sigma2_estimates,
    stop_reasons = stop_reasons,
    stop_report = stop_report,
    seed = rng_state
  )
}

### method definition ----

#' Simulate dose escalation procedure using DLE and efficacy responses with samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a method to simulate dose escalation procedure using both DLE and efficacy responses.
#' This is a method based on the [`DualResponsesSamplesDesign`] where DLE model used are of
#' [`ModelTox`] class object and efficacy model used are of [`ModelEff`]
#' class object (special case is [`EffFlexi`] class model object).
#' In addition, DLE and efficacy samples are involved or generated in the simulation
#' process.
#'
#' @param object the [`DualResponsesSamplesDesign`] object we want to
#'   simulate the data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param trueDLE (`function`)\cr a function which takes as input a dose (vector) and returns the true probability
#'   (vector) of the occurrence of a DLE. Additional arguments can be supplied in `args`.
#' @param trueEff (`function`)\cr a function which takes as input a dose (vector) and returns the expected
#'   efficacy responses (vector). Additional arguments can be supplied in `args`.
#' @param trueNu (`number`)\cr (not with [`EffFlexi`]) the precision, the inverse of the
#'   variance of the efficacy responses
#' @param trueSigma2 (`number`)\cr (only with [`EffFlexi`]) the true variance of the efficacy
#'   responses which must be a single positive scalar.
#' @param trueSigma2betaW (`number`)\cr (only with [`EffFlexi`]) the true variance for the
#'   random walk model used for smoothing. This must be a single positive scalar.
#' @param args (`data.frame`)\cr data frame with arguments for the `trueDLE` and
#'   `trueEff` function. The column names correspond to the argument
#'   names, the rows to the values of the arguments. The rows are appropriately
#'   recycled in the `nsim` simulations.
#' @param firstSeparate (`flag`)\cr enroll the first patient separately from the rest of
#'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
#'   in this patient.
#' @param mcmcOptions ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`PseudoDualSimulations`] or
#'   [`PseudoDualFlexiSimulations`]
#'
#' @example examples/design-method-simulateDualResponsesSamplesDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "DualResponsesSamplesDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    trueDLE,
    trueEff,
    trueNu = NULL,
    trueSigma2 = NULL,
    trueSigma2betaW = NULL,
    args = NULL,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    # Common checks and validations
    assert_function(trueDLE)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    # Check if special case applies
    is_flexi <- is(object@eff_model, "EffFlexi")

    # Dispatch to appropriate helper based on model type
    if (is_flexi) {
      h_simulate_flexi(
        object = object,
        nsim = nsim,
        seed = seed,
        trueDLE = trueDLE,
        trueEff = trueEff,
        trueSigma2 = trueSigma2,
        trueSigma2betaW = trueSigma2betaW,
        args = args,
        firstSeparate = firstSeparate,
        mcmcOptions = mcmcOptions,
        parallel = parallel,
        nCores = nCores
      )
    } else {
      h_simulate_nonflexi(
        object = object,
        nsim = nsim,
        seed = seed,
        trueDLE = trueDLE,
        trueEff = trueEff,
        trueNu = trueNu,
        args = args,
        firstSeparate = firstSeparate,
        mcmcOptions = mcmcOptions,
        parallel = parallel,
        nCores = nCores
      )
    }
  }
)

## DADesign ----

#' Simulate outcomes from a time-to-DLT augmented CRM design
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This method simulates dose escalation trials using time-to-DLT data,
#' where the timing of dose-limiting toxicities is explicitly modeled.
#'
#' @param object the [`DADesign`] object we want to simulate data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truthTox (`function`)\cr a function which takes as input a dose (vector) and returns the
#'   true probability (vector) for toxicity and the time DLT occurs. Additional
#'   arguments can be supplied in `args`.
#' @param truthSurv (`function`)\cr a CDF which takes as input a time (vector) and returns
#'   the true cumulative probability (vector) that the DLT would occur conditioning on the patient
#'   has DLTs.
#' @param trueTmax (`number` or `NULL`)\cr the true maximum time at which DLTs can occur.
#'   Note that this must be larger than `Tmax` from the `object`'s base data, which is
#'   the length of the DLT window, i.e. until which time DLTs are officially declared
#'   as such and used in the trial.
#' @param args (`data.frame`)\cr data frame with arguments for the `truthTox` function. The
#'   column names correspond to the argument names, the rows to the values of the
#'   arguments. The rows are appropriately recycled in the `nsim`
#'   simulations. In order to produce outcomes from the posterior predictive
#'   distribution, e.g, pass an `object` that contains the data observed so
#'   far, `truthTox` contains the `prob` function from the model in
#'   `object`, and `args` contains posterior samples from the model.
#' @param firstSeparate (`flag`)\cr enroll the first patient separately from the rest of
#'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
#'   in this patient.
#' @param deescalate (`flag`)\cr allow deescalation when a DLT occurs in cohorts with lower dose
#'   level? (default: TRUE)
#' @param mcmcOptions ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used.
#' @param DA (`flag`)\cr use dose-adaptation rules? (default: TRUE)
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param derive (`list`)\cr a named list of functions which derives statistics, based on the
#'   vector of posterior MTD samples. Each list element must therefore accept
#'   one and only one argument, which is a numeric vector, and return a number.
#' @param ... not used
#'
#' @return an object of class [`Simulations`]
#'
#' @example examples/design-method-simulate-DADesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "DADesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    truthTox,
    truthSurv,
    trueTmax = NULL,
    args = NULL,
    firstSeparate = FALSE,
    deescalate = TRUE,
    mcmcOptions = McmcOptions(),
    DA = TRUE,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5),
    derive = list(),
    ...
  ) {
    # Validate inputs
    assert_function(truthTox)
    assert_function(truthSurv)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)

    # Seed handling
    rng_state <- set_seed(seed)

    # Generate individual seeds for simulation runs
    sim_seeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    # Define inverse function for DLT survival generation.
    inverse <- function(f, lower = -100, upper = 100) {
      function(y) {
        uniroot((function(x) f(x) - y), lower = lower, upper = upper)[1]$root
      }
    }

    # Get DLT window length.
    data <- object@data
    t_max <- data@Tmax

    if (is.null(trueTmax)) {
      trueTmax <- t_max
    } else if (trueTmax < t_max) {
      warning("trueTmax < Tmax! trueTmax is set to Tmax")
      trueTmax <- t_max
    }

    # Calculate the inverse function of survival to DLT CDF.
    inverse_truth_surv <- inverse(truthSurv, 0, trueTmax)

    # Generate random survival times for DLT data.
    # Returns t_max when no DLT occurs.
    generate_surv_times <- function(
      dlt,
      t_max,
      inverse_surv = inverse_truth_surv
    ) {
      surv_times <- rep(-100, length(dlt))

      if (sum(dlt == 0) > 0) {
        surv_times[dlt == 0] <- t_max
      }

      if (sum(dlt == 1) > 0) {
        surv_times[dlt == 1] <- unlist(lapply(
          runif(sum(dlt == 1), 0, 1),
          inverse_surv
        ))
      }

      # Ensure results are always positive.
      surv_times[surv_times <= 0] <- 0.05
      surv_times
    }

    # Check if follow-up requirements are fulfilled for opening next cohort.
    ready_to_open <- function(day, window, surv_times) {
      cohort_size <- length(surv_times)
      # Calculate when patients start.
      start_time <- apply(
        rbind(surv_times[-cohort_size], window$patientGap[-1]),
        2,
        min
      )
      # Calculate relative time for each patient on the specified day.
      individual_check <- day - cumsum(c(0, start_time))
      # Ensure minimum is 0.
      individual_check[individual_check < 0] <- 0
      follow_up <- apply(rbind(surv_times, individual_check), 2, min)

      all(
        (follow_up -
          apply(rbind(window$patientFollow, surv_times), 2, min)) >=
          0
      ) &
        (max(follow_up) >= min(window$patientFollowMin, max(surv_times)))
    }

    # Determine when to open the next cohort.
    # Assumes sufficient patients are available for immediate enrollment.
    next_open <- function(window, surv_times) {
      cohort_size <- length(surv_times)

      window$patientGap <- window$patientGap[1:cohort_size]
      # If DLT happens before end of DLT window, next cohort opens earlier.
      start_time <- apply(
        rbind(surv_times[-cohort_size], window$patientGap[-1]),
        2,
        min
      )
      # Duration until all DLT windows finished.
      max_time <- max(surv_times + cumsum(c(0, start_time)))

      requirements_met <- sapply(1:max_time, function(i) {
        ready_to_open(i, window, surv_times)
      })
      if (sum(requirements_met) > 0) {
        # Earliest time that requirements are met.
        time <- min(c(1:max_time)[requirements_met])
      } else {
        time <- max_time
      }
      time
    }

    # Function to run a single simulation.
    run_sim <- function(iter_sim) {
      # Set the seed for this run.
      set.seed(sim_seeds[iter_sim])

      # Get current arguments (appropriately recycled).
      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      # Truth function with current arguments.
      truth_with_args <- function(dose) {
        do.call(
          truthTox,
          c(
            dose,
            current_args
          )
        )
      }

      # Start with the provided data.
      data <- object@data

      # Handle placebo if present.
      if (data@placebo) {
        prob_pl <- truth_with_args(object@data@doseGrid[1])
      }

      # Trial control variables.
      should_stop <- FALSE
      trial_time <- 0

      # Initialize observed DLT data.
      observed_dlts <- data@y
      observed_surv <- data@u
      observed_t0 <- data@t0

      # Initialize with starting dose.
      dose <- object@startingDose

      # Main simulation loop.
      while (!should_stop) {
        # Calculate toxicity probability at current dose.
        prob <- truth_with_args(dose)

        # Determine cohort size.
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        if (data@placebo) {
          placebo_size <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        total_size <- if (data@placebo) {
          cohort_size + placebo_size
        } else {
          cohort_size
        }

        safety_window <- windowLength(object@safetyWindow, total_size)

        # Simulate DLTs for cohort.
        # If any patient has DLT before first patient finishes staggered window,
        # further enrollment will be stopped.
        h_generate_dlt_and_surv <- function(n, prob, start = NULL) {
          dlts <- rbinom(
            n = n,
            size = 1L,
            prob = prob
          )
          surv_times <- ceiling(generate_surv_times(
            dlts,
            trueTmax,
            inverse_surv = inverse_truth_surv
          ))

          if (!is.null(start)) {
            dlts <- c(start$dlts, dlts)
            surv_times <- c(start$surv, surv_times)
          }

          if (t_max < trueTmax) {
            dlts[dlts == 1 & surv_times > t_max] <- 0

            surv_times <- apply(
              rbind(surv_times, rep(t_max, length(surv_times))),
              2,
              min
            )
          }

          list(dlts = dlts, surv = surv_times)
        }

        # Update data with active and placebo cohorts.
        h_update_data_da <- function(active, placebo, time) {
          result <- update(
            object = data,
            y = c(observed_dlts, active$dlts),
            u = c(observed_surv, active$surv),
            t0 = c(observed_t0, cohort_t0),
            x = dose,
            trialtime = time
          )

          if (data@placebo) {
            result <- update(
              object = result,
              y = c(observed_dlts, active$dlts, placebo$dlts),
              u = c(observed_surv, active$surv, placebo$surv),
              t0 = c(
                observed_t0,
                cohort_t0,
                rep(cohort_t0[1], length(placebo$dlts))
              ),
              x = object@data@doseGrid[1],
              trialtime = time
            )
          }

          result
        }

        if (firstSeparate && (cohort_size > 1L)) {
          # Dose the first patient.
          active_dlt_surv <- h_generate_dlt_and_surv(1L, prob)
          placebo_dlt_surv <- if (data@placebo && (placebo_size > 0L)) {
            # If placebo, also dose one placebo patient.
            h_generate_dlt_and_surv(1L, prob_pl)
          } else {
            list()
          }

          cohort_t0 <- trial_time

          # Check if there are DLTs during safety window.
          temp_data <- h_update_data_da(
            active_dlt_surv,
            placebo_dlt_surv,
            trial_time + safety_window$patientGap[2]
          )
          temp_time <- (temp_data@u + temp_data@t0)[
            temp_data@y == 1 & temp_data@x <= dose
          ]

          # If no DLTs occur during safety window, enroll remaining patients.
          if (sum(temp_time > trial_time) == 0) {
            # Enroll the remaining patients.
            active_dlt_surv <- h_generate_dlt_and_surv(
              cohort_size - 1L,
              prob,
              start = active_dlt_surv
            )
            placebo_dlt_surv <- if (data@placebo && (placebo_size > 1L)) {
              h_generate_dlt_and_surv(
                placebo_size - 1L,
                prob_pl,
                start = placebo_dlt_surv
              )
            } else {
              list()
            }

            # Adjust for DLTs happening before end of safety window.
            real_window <- apply(
              rbind(
                c(active_dlt_surv$surv, placebo_dlt_surv$surv)[-cohort_size],
                safety_window$patientGap[-1]
              ),
              2,
              min
            )

            cohort_t0 <- trial_time + c(0, cumsum(real_window))
          }

          rm(temp_data)
          rm(temp_time)
        } else {
          # Directly dose all patients.
          active_dlt_surv <- h_generate_dlt_and_surv(
            cohort_size,
            prob
          )
          placebo_dlt_surv <- if (data@placebo) {
            h_generate_dlt_and_surv(
              placebo_size,
              prob_pl
            )
          } else {
            list()
          }

          # Adjust for DLTs happening before end of safety window.
          real_window <- apply(
            rbind(
              c(active_dlt_surv$surv, placebo_dlt_surv$surv)[-cohort_size],
              safety_window$patientGap[-1]
            ),
            2,
            min
          )

          cohort_t0 <- trial_time + c(0, cumsum(real_window))
        }

        # Update observed data with new cohort.
        old_dlts <- observed_dlts

        observed_dlts <- c(
          observed_dlts,
          placebo_dlt_surv$dlts,
          active_dlt_surv$dlts
        )

        observed_surv <- c(
          observed_surv,
          placebo_dlt_surv$surv,
          active_dlt_surv$surv
        )

        observed_t0 <- c(
          observed_t0,
          rep(cohort_t0[1], length(placebo_dlt_surv$dlts)),
          rep(cohort_t0, length.out = length(active_dlt_surv$dlts))
        )

        time_to_next <- next_open(
          window = safety_window,
          surv_times = c(placebo_dlt_surv$surv, active_dlt_surv$surv)
        )

        # Handle deescalation if DLTs occur in previous cohorts.
        if (deescalate == TRUE) {
          are_dlts_after_trial_start <- (observed_surv + observed_t0) >
            trial_time
          are_dlts_before_open_next_cohort <- (observed_surv +
            observed_t0 -
            trial_time) <=
            time_to_next
          are_dlts_happening <- observed_dlts == 1
          is_new_dlt <- (are_dlts_after_trial_start &
            are_dlts_before_open_next_cohort &
            are_dlts_happening)

          new_dlt_ids <- seq_along(observed_dlts)[is_new_dlt]
          last_id_previous_cohort <- length(old_dlts)
          is_new_dlt_in_previous_cohort <- new_dlt_ids <=
            last_id_previous_cohort

          new_dlt_ids <- new_dlt_ids[is_new_dlt_in_previous_cohort]

          if (length(new_dlt_ids) > 0) {
            for (this_new_dlt_id in new_dlt_ids) {
              this_new_dlt_time <- (observed_surv + observed_t0)[
                this_new_dlt_id
              ]

              # Identify patients at higher doses who are impacted.
              later_ids <- c(this_new_dlt_id:length(observed_dlts))
              all_doses <- c(data@x, rep(dose, length(active_dlt_surv$dlts)))
              this_new_dlt_dose <- all_doses[this_new_dlt_id]
              is_dose_higher_than_this_new_dlt_dose <- all_doses[later_ids] >
                this_new_dlt_dose
              ids_to_deescalate <- later_ids[
                is_dose_higher_than_this_new_dlt_dose
              ]

              if (length(ids_to_deescalate) > 0) {
                # DLT will be observed once follow-up time >= time to DLT.
                this_new_dlt_time_after_followup <- this_new_dlt_time >=
                  (observed_t0[ids_to_deescalate] +
                    observed_surv[ids_to_deescalate])
                observed_dlts[ids_to_deescalate] <- as.integer(
                  observed_dlts[ids_to_deescalate] *
                    this_new_dlt_time_after_followup
                )

                # Some patients in later cohorts may not be enrolled yet when new DLT occurs.
                # Remove those patients from the cohort.
                ids_not_enrolled <- ids_to_deescalate[
                  (observed_t0[ids_to_deescalate] >= this_new_dlt_time)
                ]

                ids_enrolled <- setdiff(
                  ids_to_deescalate,
                  ids_not_enrolled
                )

                # Update DLT-free survival time for already enrolled patients.
                if (length(ids_enrolled) > 0) {
                  surv_time <- pmin(
                    observed_surv[ids_enrolled],
                    this_new_dlt_time - observed_t0[ids_enrolled]
                  )
                  assert_true(all(surv_time >= 0))

                  observed_surv[ids_enrolled] <- surv_time
                }

                # Remove patients not yet enrolled.
                if (length(ids_not_enrolled) > 0) {
                  observed_surv <- observed_surv[-ids_not_enrolled]
                  observed_t0 <- observed_t0[-ids_not_enrolled]
                  observed_dlts <- observed_dlts[-ids_not_enrolled]
                }
              }
            }

            time_to_next <- min(
              time_to_next,
              max((observed_surv + observed_t0)[
                (length(old_dlts) + 1):length(observed_dlts)
              ]) -
                trial_time
            )
          }
        }

        # Update trial time.
        trial_time <- trial_time + time_to_next

        # Update data object with observations available when next cohort opens.
        if (data@placebo) {
          # First patients are from placebo.
          data <- update(
            object = data,
            y = head(observed_dlts, -length(active_dlt_surv$dlts)),
            u = head(observed_surv, -length(active_dlt_surv$surv)),
            t0 = head(observed_t0, -length(active_dlt_surv$surv)),
            x = object@data@doseGrid[1],
            trialtime = trial_time
          )
        }
        data <- update(
          object = data,
          y = observed_dlts,
          u = observed_surv,
          t0 = observed_t0,
          x = dose,
          trialtime = trial_time
        )

        try(
          if (
            length(data@x) != length(data@u) ||
              length(data@u) != length(data@y)
          ) {
            stop("x,y,u dimension error")
          }
        )

        # Calculate dose limit.
        dose_limit <- maxDose(object@increments, data = data)

        # Generate MCMC samples from model.
        if (DA == TRUE) {
          samples <- mcmc(
            data = data,
            model = object@model,
            options = mcmcOptions
          )
        } else if (DA == FALSE) {
          temp_model <- LogisticLogNormal(
            mean = object@model@params@mean,
            cov = object@model@params@cov,
            ref_dose = object@model@refDose
          )

          truncated_data <- Data(
            x = data@x,
            y = data@y,
            doseGrid = data@doseGrid,
            cohort = data@cohort,
            ID = data@ID
          )

          samples <- mcmc(
            data = truncated_data,
            model = temp_model,
            options = mcmcOptions
          )
        }

        # Calculate next best dose.
        dose <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = object@model,
          data = data
        )$value

        # Evaluate stopping rules.
        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          samples = samples,
          model = object@model,
          data = data
        )
        stop_results <- h_unpack_stopit(should_stop)
      }

      # Calculate final model fit.
      fit_result <- fit(
        object = samples,
        model = object@model,
        data = data
      )

      # Get MTD estimate from samples.
      target_dose_samples <- dose(
        mean(object@nextBest@target),
        model = object@model,
        samples = samples
      )

      # Calculate additional statistics.
      additional_stats <- lapply(derive, function(f) f(target_dose_samples))

      # Return simulation results.
      list(
        data = data,
        dose = dose,
        duration = trial_time,
        fit = subset(fit_result, select = c(middle, lower, upper)),
        stop = attr(
          should_stop,
          "message"
        ),
        report_results = stop_results,
        additional_stats = additional_stats
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "truthTox",
        "truthSurv",
        "object",
        "mcmcOptions",
        "next_open",
        "ready_to_open"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    # Process simulation results.
    data_list <- lapply(result_list, "[[", "data")
    recommended_doses <- as.numeric(sapply(result_list, "[[", "dose"))
    trial_duration <- as.numeric(sapply(result_list, "[[", "duration"))
    fit_list <- lapply(result_list, "[[", "fit")

    stop_reasons <- lapply(result_list, "[[", "stop")

    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    additional_stats <- lapply(result_list, "[[", "additional_stats")

    # Return simulation results.
    DASimulations(
      data = data_list,
      doses = recommended_doses,
      fit = fit_list,
      trial_duration = trial_duration,
      stop_report = stop_report,
      stop_reasons = stop_reasons,
      additional_stats = additional_stats,
      seed = rng_state
    )
  }
)

## DesignGrouped ----

#' Simulate Method for the [`DesignGrouped`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simulate method for [`DesignGrouped`] designs.
#'
#' @param object (`DesignGrouped`)\cr the design we want to simulate trials from.
#' @param nsim (`number`)\cr how many trials should be simulated.
#' @param seed (`RNGstate`)\cr generated with [set_seed()].
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and
#'   returns the true probability (vector) for toxicity for the mono arm.
#'   Additional arguments can be supplied in `args`.
#' @param combo_truth (`function`)\cr same as `truth` but for the combo arm.
#' @param args (`data.frame`)\cr optional `data.frame` with arguments that work
#'   for both the `truth` and `combo_truth` functions. The column names correspond to
#'   the argument names, the rows to the values of the arguments. The rows are
#'   appropriately recycled in the `nsim` simulations.
#' @param firstSeparate (`flag`)\cr whether to enroll the first patient separately
#'   from the rest of the cohort and close the cohort in case a DLT occurs in this
#'   first patient.
#' @param mcmcOptions (`McmcOptions`)\cr MCMC options for each evaluation in the trial.
#' @param parallel (`flag`)\cr whether the simulation runs are parallelized across the
#'   cores of the computer.
#' @param nCores (`number`)\cr how many cores should be used for parallel computing.
#' @param ... not used.
#'
#' @return A list of `mono` and `combo` simulation results as [`Simulations`] objects.
#'
#' @aliases simulate-DesignGrouped
#' @export
#' @example examples/Design-method-simulate-DesignGrouped.R
#'
setMethod(
  "simulate",
  signature = signature(
    object = "DesignGrouped",
    nsim = "ANY",
    seed = "ANY"
  ),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    combo_truth,
    args = data.frame(),
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallelly::availableCores(), 5),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_function(combo_truth)
    assert_data_frame(args)
    assert_count(nsim, positive = TRUE)
    assert_flag(firstSeparate)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)
    sim_seeds <- sample.int(n = 2147483647, size = nsim)

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])
      current <- list(mono = list(), combo = list())
      # Define true toxicity functions.
      current$args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]
      current$mono$truth <- function(dose) do.call(truth, c(dose, current$args))
      current$combo$truth <- function(dose) {
        do.call(combo_truth, c(dose, current$args))
      }
      # Start the simulated data with the provided one.
      current$mono$data <- object@mono@data
      current$combo$data <- object@combo@data
      # We are in the first cohort and continue for mono and combo.
      current$first <- TRUE
      current$mono$stop <- current$combo$stop <- FALSE

      # What are the next doses to be used? Initialize with starting doses.
      if (
        object@same_dose_for_all ||
          (!object@first_cohort_mono_only && object@same_dose_for_start)
      ) {
        current$mono$dose <- current$combo$dose <- min(
          object@mono@startingDose,
          object@combo@startingDose
        )
      } else {
        current$mono$dose <- object@mono@startingDose
        current$combo$dose <- object@combo@startingDose
      }

      # Inside this loop we simulate the whole trial, until stopping.
      while (!(current$mono$stop && current$combo$stop)) {
        if (!current$mono$stop) {
          cohort_size_mono <- size(
            object@mono@cohort_size,
            dose = current$mono$dose,
            data = current$mono$data
          )
          this_prob_mono <- current$mono$truth(current$mono$dose)
          current$mono$data <- current$mono$data %>%
            h_determine_dlts(
              dose = current$mono$dose,
              prob = this_prob_mono,
              cohort_size = cohort_size_mono,
              first_separate = firstSeparate
            )
        }
        if (
          !current$combo$stop &&
            (!current$first || !object@first_cohort_mono_only)
        ) {
          cohort_size_combo <- size(
            object@combo@cohort_size,
            dose = current$combo$dose,
            data = current$combo$data
          )
          this_prob_combo <- current$combo$truth(current$combo$dose)
          current$combo$data <- current$combo$data %>%
            h_determine_dlts(
              dose = current$combo$dose,
              prob = this_prob_combo,
              cohort_size = cohort_size_combo,
              first_separate = firstSeparate
            )
        }

        current$grouped <- h_group_data(current$mono$data, current$combo$data)
        current$samples <- mcmc(current$grouped, object@model, mcmcOptions)
        if (!current$mono$stop) {
          current$mono$limit <- maxDose(
            object@mono@increments,
            data = current$mono$data
          )
          current$mono$dose <- object@mono@nextBest %>%
            nextBest(
              current$mono$limit,
              current$samples,
              object@model,
              current$grouped,
              group = "mono"
            )
          current$mono$dose <- current$mono$dose$value
        }
        if (
          !current$combo$stop &&
            (!current$first || !object@first_cohort_mono_only)
        ) {
          current$combo$limit <- if (is.na(current$mono$dose)) {
            0
          } else {
            maxDose(object@combo@increments, current$combo$data) %>%
              min(current$mono$dose, na.rm = TRUE)
          }
          current$combo$dose <- object@combo@nextBest %>%
            nextBest(
              current$combo$limit,
              current$samples,
              object@model,
              current$grouped,
              group = "combo"
            )
          current$combo$dose <- current$combo$dose$value
          current$combo$stop <- object@combo@stopping %>%
            stopTrial(
              current$combo$dose,
              current$samples,
              object@model,
              current$combo$data,
              group = "combo"
            )
          current$combo$results <- h_unpack_stopit(current$combo$stop)
        }
        if (!current$mono$stop) {
          current$mono$stop <- object@mono@stopping %>%
            stopTrial(
              current$mono$dose,
              current$samples,
              object@model,
              current$mono$data,
              group = "mono",
              external = current$combo$stop
            )
          current$mono$results <- h_unpack_stopit(current$mono$stop)
        }
        if (
          object@same_dose_for_all && !current$mono$stop && !current$combo$stop
        ) {
          current$mono$dose <- current$combo$dose <- min(
            current$mono$dose,
            current$combo$dose
          )
        }
        if (current$first) {
          current$first <- FALSE
          if (object@first_cohort_mono_only && object@same_dose_for_start) {
            current$mono$dose <- current$combo$dose <- min(
              current$mono$dose,
              current$combo$dose
            )
          }
        }
      }
      current$mono$fit <- fit(
        current$samples,
        object@model,
        current$grouped,
        group = "mono"
      )
      current$combo$fit <- fit(
        current$samples,
        object@model,
        current$grouped,
        group = "combo"
      )
      lapply(
        X = current[c("mono", "combo")],
        FUN = with,
        list(
          data = data,
          dose = dose,
          fit = subset(fit, select = -dose),
          stop = attr(stop, "message"),
          results = results
        )
      )
    }
    vars_needed <- c(
      "simSeeds",
      "args",
      "nArgs",
      "truth",
      "combo_truth",
      "firstSeparate",
      "object",
      "mcmcOptions"
    )

    result_list <- get_result_list(run_sim, nsim, vars_needed, parallel, nCores)
    # Now we have a list with each element containing mono and combo. Reorder this a bit:
    result_list <- list(
      mono = lapply(result_list, "[[", "mono"),
      combo = lapply(result_list, "[[", "combo")
    )
    # Put everything in a list with both mono and combo Simulations:
    lapply(result_list, function(this_list) {
      data_list <- lapply(this_list, "[[", "data")
      recommended_doses <- as.numeric(sapply(this_list, "[[", "dose"))
      fit_list <- lapply(this_list, "[[", "fit")
      stop_reasons <- lapply(this_list, "[[", "stop")
      report_results <- lapply(this_list, "[[", "results")
      stop_report <- as.matrix(do.call(rbind, report_results))
      additional_stats <- lapply(this_list, "[[", "additional_stats")

      Simulations(
        data = data_list,
        doses = recommended_doses,
        fit = fit_list,
        stop_reasons = stop_reasons,
        stop_report = stop_report,
        additional_stats = additional_stats,
        seed = rng_state
      )
    })
  }
)

# examine ----

#' Obtain Hypothetical Trial Course Table for a Design
#'
#' This generic function takes a design and generates a `data.frame`
#' showing the beginning of several hypothetical trial courses under
#' the design. This means, from the generated `data.frame` one can read off:
#'
#' - how many cohorts are required in the optimal case (no DLTs observed) in
#'   order to reach the highest dose of the specified dose grid (or until
#'   the stopping rule is fulfilled)
#' - assuming no DLTs are observed until a certain dose level, what the next
#'   recommended dose is for all possible number of DLTs observed
#' - the actual relative increments that will be used in these cases
#' - whether the trial would stop at a certain cohort
#'
#' Examining the "single trial" behavior of a dose escalation design is
#' the first important step in evaluating a design, and cannot be replaced by
#' studying solely the operating characteristics in "many trials". The cohort
#' sizes are also taken from the design, assuming no DLTs occur until the dose
#' listed.
#'
#' @param object ([`Design`] or [`RuleDesign`])\cr the design we want to examine
#' @param ... additional arguments (see methods)
#' @param maxNoIncrement maximum number of contiguous next doses at 0
#'   DLTs that are the same as before, i.e. no increment (default to 100)
#'
#' @return The data frame
#'
#' @export
#' @keywords methods regression
setGeneric(
  "examine",
  def = function(object, ..., maxNoIncrement = 100L) {
    assert_count(maxNoIncrement, positive = TRUE)
    standardGeneric("examine")
  },
  valueClass = "data.frame"
)

## Design ----

#' @describeIn examine Examine a model-based CRM.
#'
#' @param mcmcOptions ([`McmcOptions`])\cr giving the MCMC options
#'   for each evaluation in the trial. By default, the standard options are used.
#'
#' @example examples/design-method-examine-Design.R
setMethod(
  "examine",
  signature = signature(object = "Design"),
  def = function(object, mcmcOptions = McmcOptions(), ..., maxNoIncrement) {
    ret <- data.frame(
      dose = numeric(),
      DLTs = integer(),
      nextDose = numeric(),
      stop = logical(),
      increment = integer()
    )
    base_data <- object@data

    should_stop <- FALSE

    # Counter how many contiguous doses at 0 DLTs with no increment.
    no_increment_counter <- 0L

    # Initialize with starting dose.
    dose <- object@startingDose

    while (!should_stop) {
      # What is the cohort size at this dose?
      cohort_size <- size(object@cohort_size, dose = dose, data = base_data)

      if (base_data@placebo) {
        cohort_size_pl <- size(
          object@pl_cohort_size,
          dose = dose,
          data = base_data
        )
      }

      # For all possible number of DLTs:
      for (num_dlts in 0:cohort_size) {
        # Update data with corresponding DLT vector.
        if (base_data@placebo && (cohort_size_pl > 0L)) {
          data_updated <- update(
            object = base_data,
            x = base_data@doseGrid[1],
            y = rep(0, cohort_size_pl),
            check = FALSE
          )

          data_updated <- update(
            object = data_updated,
            x = dose,
            y = rep(
              x = c(0, 1),
              times = c(
                cohort_size - num_dlts,
                num_dlts
              )
            ),
            new_cohort = FALSE
          )
        } else {
          data_updated <- update(
            object = base_data,
            x = dose,
            y = rep(
              x = c(0, 1),
              times = c(
                cohort_size - num_dlts,
                num_dlts
              )
            )
          )
        }

        # Calculate dose limit.
        dose_limit <- maxDose(object@increments, data = data_updated)

        # Generate samples from the model.
        samples <- mcmc(
          data = data_updated,
          model = object@model,
          options = mcmcOptions
        )

        # Calculate next best dose.
        next_dose <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = object@model,
          data = data_updated
        )$value

        # Compute relative increment in percent.
        increment <- round((next_dose - dose) / dose * 100)

        # Evaluate stopping rules.
        stop_this_trial <- stopTrial(
          object@stopping,
          dose = next_dose,
          samples = samples,
          model = object@model,
          data = data_updated
        )

        # Append information to the data frame.
        ret <- rbind(
          ret,
          list(
            dose = dose,
            DLTs = num_dlts,
            nextDose = next_dose,
            stop = stop_this_trial,
            increment = as.integer(increment)
          )
        )
      }

      # Update base data.
      if (base_data@placebo && (cohort_size_pl > 0L)) {
        base_data <- update(
          object = base_data,
          x = base_data@doseGrid[1],
          y = rep(0, cohort_size_pl),
          check = FALSE
        )

        base_data <- update(
          object = base_data,
          x = dose,
          y = rep(0, cohort_size),
          new_cohort = FALSE
        )
      } else {
        base_data <- update(
          object = base_data,
          x = dose,
          y = rep(0, cohort_size)
        )
      }

      # Extract results if 0 DLTs.
      results_no_dlts <- subset(
        tail(ret, cohort_size + 1),
        dose == dose & DLTs == 0
      )

      # Determine new dose.
      new_dose <- as.numeric(results_no_dlts$nextDose)

      # Calculate difference to previous dose.
      dose_diff <- new_dose - dose

      # Update the counter for no increments of the dose.
      if (dose_diff == 0) {
        no_increment_counter <- no_increment_counter + 1L
      } else {
        no_increment_counter <- 0L
      }

      # Check if stopping rule would be fulfilled.
      stop_already <- results_no_dlts$stop

      # Update dose.
      dose <- new_dose

      # Check if too many times no increment.
      stop_no_increment <- (no_increment_counter >= maxNoIncrement)
      if (stop_no_increment) {
        warning(paste(
          "Stopping because",
          no_increment_counter,
          "times no increment vs. previous dose"
        ))
      }

      # Check if we can stop:
      # Either when we have reached the highest dose in the next cohort,
      # or when the stopping rule is already fulfilled,
      # or when too many times no increment.
      should_stop <- (dose >= max(object@data@doseGrid)) ||
        stop_already ||
        stop_no_increment
    }
    ret
  }
)

## RuleDesign ----

#' @describeIn examine Examine a rule-based design.
#' @example examples/design-method-examine-RuleDesign.R
setMethod(
  "examine",
  signature = signature(object = "RuleDesign"),
  def = function(object, ..., maxNoIncrement) {
    # Start with the empty table.
    ret <- data.frame(
      dose = numeric(),
      DLTs = integer(),
      nextDose = numeric(),
      stop = logical(),
      increment = integer()
    )

    # Start the base data with the provided one.
    base_data <- object@data

    # Are we finished and can stop?
    should_stop <- FALSE

    # Counter: contiguous doses at 0 DLTs with no increment.
    no_increment_counter <- 0L

    # Initialize with starting dose.
    dose <- object@startingDose

    # Continue filling up the table until stopping.
    while (!should_stop) {
      # Cohort size at this dose.
      cohort_size <- size(object@cohort_size, dose = dose, data = base_data)

      # For all possible number of DLTs.
      for (num_dlts in 0:cohort_size) {
        # Update data with corresponding DLT vector.
        data_updated <- update(
          object = base_data,
          x = dose,
          y = rep(
            x = c(0, 1),
            times = c(
              cohort_size - num_dlts,
              num_dlts
            )
          )
        )

        # Evaluate the rule.
        outcome <- nextBest(object@nextBest, data = data_updated)

        # Next dose and whether to stop here.
        next_dose <- outcome$value
        stop_this_trial <- outcome$stopHere

        # Compute relative increment in percent.
        increment <- round((next_dose - dose) / dose * 100)

        # Append information to the data frame.
        ret <- rbind(
          ret,
          list(
            dose = dose,
            DLTs = num_dlts,
            nextDose = next_dose,
            stop = stop_this_trial,
            increment = as.integer(increment)
          )
        )
      }

      # Change base data.
      base_data <- update(
        object = base_data,
        x = dose,
        y = rep(0, cohort_size)
      )

      # Results if 0 DLTs.
      results_no_dlts <- subset(
        tail(ret, cohort_size + 1),
        dose == dose & DLTs == 0
      )

      # New dose and difference to previous dose.
      new_dose <- as.numeric(results_no_dlts$nextDose)
      dose_diff <- new_dose - dose

      # Update the counter for no increments of the dose.
      if (dose_diff == 0) {
        no_increment_counter <- no_increment_counter + 1L
      } else {
        no_increment_counter <- 0L
      }

      # Would stopping rule be fulfilled already?
      stop_already <- results_no_dlts$stop

      # Update dose.
      dose <- new_dose

      # Too many times no increment?
      stop_no_increment <- (no_increment_counter >= maxNoIncrement)
      if (stop_no_increment) {
        warning(paste(
          "Stopping because",
          no_increment_counter,
          "times no increment vs. previous dose"
        ))
      }

      # Check if we can stop:
      # highest dose reached next cohort, stopping rule fulfilled, or too many no-increment.
      should_stop <- (dose >= max(object@data@doseGrid)) ||
        stop_already ||
        stop_no_increment
    }

    ret
  }
)

## DADesign ----

#' @describeIn examine Examine a model-based CRM.
#'
#' @param mcmcOptions ([`McmcOptions`])\cr
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used
#'
#' @example examples/design-method-examine-DADesign.R
setMethod(
  "examine",
  signature = signature(object = "DADesign"),
  def = function(object, mcmcOptions = McmcOptions(), ..., maxNoIncrement) {
    # Check follow-up sufficiency (TRUE/FALSE);
    ready_to_open <- function(day, window, this_surv) {
      size <- length(this_surv)
      start_time <- apply(
        rbind(this_surv[-size], window$patientGap[-1]),
        2,
        min
      )
      individual_check <- day - cumsum(c(0, start_time))
      individual_check[individual_check < 0] <- 0
      follow_up <- apply(rbind(this_surv, individual_check), 2, min)
      all(
        (follow_up - apply(rbind(window$patientFollow, this_surv), 2, min)) >= 0
      ) &&
        (max(follow_up) >= min(window$patientFollowMin, max(this_surv)))
    }

    # Determine when to open the next cohort; applies to all trials.
    next_open <- function(window, this_surv) {
      size <- length(this_surv)
      window$patientGap <- window$patientGap[1:size]
      start_time <- apply(
        rbind(this_surv[-size], window$patientGap[-1]),
        2,
        min
      )
      max_t <- max(this_surv + cumsum(c(0, start_time)))

      met <- sapply(1:max_t, function(i) ready_to_open(i, window, this_surv))
      if (sum(met) > 0) min(c(1:max_t)[met]) else max_t
    }

    # Initialize result table.
    ret <- data.frame(
      DLTsearly_1 = integer(),
      dose = numeric(),
      DLTs = integer(),
      nextDose = numeric(),
      stop = logical(),
      increment = integer()
    )

    # Base data and trial state.
    base_data <- object@data
    should_stop <- FALSE
    dose <- object@startingDose

    # Observed facts trackers (cumulative across cohorts).
    observed_dlts <- base_data@y
    observed_surv <- base_data@u
    observed_t0 <- base_data@t0

    # Global trial clock and previous cohort timing.
    trial_time <- 0
    prev_time <- 0

    # DLT window length.
    t_max <- base_data@Tmax

    # Number of patients with unfinished DLT window (initially none).
    prev_size <- 0

    # Iterate cohorts until stopping.
    while (!should_stop) {
      cohort_size <- size(object@cohort_size, dose = dose, data = base_data)
      safety_window <- windowLength(object@safetyWindow, cohort_size)

      # When cohort patients start relative to trial clock.

      cohort_t0 <- trial_time + cumsum(safety_window$patientGap)

      # Append placeholders for the incoming cohort (no DLTs yet, censored at t_max).
      observed_dlts <- c(observed_dlts, rep(0, cohort_size))
      observed_surv <- c(observed_surv, rep(t_max, cohort_size))
      observed_t0 <- c(observed_t0, cohort_t0)

      # Advance time until next cohort may open (all follow-up constraints satisfied).
      trial_time <- trial_time +
        next_open(window = safety_window, this_surv = rep(t_max, cohort_size))

      # Count patients still within DLT window (for nFollow loop).
      n_follow <- cohort_size + prev_size

      # Identify censored patients indices.
      npt <- length(base_data@x)
      censored_indices <- c(
        which((trial_time - base_data@t0) < base_data@Tmax & base_data@y == 0),
        (npt + 1):(npt + cohort_size)
      )

      # For all possible number of DLTs (0..n_follow):
      for (num_dlts in 0:n_follow) {
        if (num_dlts == 0) {
          # Update base_data for zero DLTs scenario.
          base_data <- update(
            object = base_data,
            y = observed_dlts,
            u = observed_surv,
            t0 = observed_t0,
            x = dose,
            trialtime = trial_time
          )

          dose_limit <- maxDose(object@increments, data = base_data)
          samples <- mcmc(
            data = base_data,
            model = object@model,
            options = mcmcOptions
          )
          next_dose <- nextBest(
            object@nextBest,
            doselimit = dose_limit,
            samples = samples,
            model = object@model,
            data = base_data
          )$value

          increment <- round((next_dose - dose) / dose * 100)
          stop_this_trial <- stopTrial(
            object@stopping,
            dose = next_dose,
            samples = samples,
            model = object@model,
            data = base_data
          )

          ret <- rbind(
            ret,
            list(
              DLTsearly_1 = 0,
              dose = dose,
              DLTs = num_dlts,
              nextDose = next_dose,
              stop = stop_this_trial,
              increment = as.integer(increment)
            )
          )
        } else {
          # Consider two extremes: DLTs at longest vs shortest follow-ups.
          for (dlt_early in 1:num_dlts) {
            curr_dlts <- observed_dlts
            curr_surv <- observed_surv

            if (dlt_early == 1) {
              # Longest follow-up patients have DLTs.
              curr_dlts[censored_indices][1:num_dlts] <- 1
              curr_surv[censored_indices][1:num_dlts] <- apply(
                rbind(
                  rep(t_max, num_dlts),
                  trial_time - observed_t0[censored_indices][1:num_dlts]
                ),
                2,
                min
              )

              data_current <- update(
                object = base_data,
                y = curr_dlts,
                u = curr_surv,
                t0 = observed_t0,
                x = dose,
                trialtime = trial_time
              )
            } else {
              # Shortest follow-up patients have DLTs.
              curr_dlts[rev(censored_indices)][1:num_dlts] <- 1
              curr_surv[rev(censored_indices)][1:num_dlts] <- apply(
                rbind(
                  rep(1, num_dlts),
                  prev_time + 1 - observed_t0[rev(censored_indices)][1:num_dlts]
                ),
                2,
                max
              )

              temp_time <- if (num_dlts >= cohort_size) {
                1 + max(cohort_t0)
              } else {
                trial_time
              }

              data_current <- update(
                object = base_data,
                y = curr_dlts,
                u = curr_surv,
                t0 = observed_t0,
                x = dose,
                trialtime = temp_time
              )
            }

            dose_limit <- maxDose(object@increments, data = data_current)
            samples <- mcmc(
              data = data_current,
              model = object@model,
              options = mcmcOptions
            )
            next_dose <- nextBest(
              object@nextBest,
              doselimit = dose_limit,
              samples = samples,
              model = object@model,
              data = data_current
            )$value

            increment <- round((next_dose - dose) / dose * 100)
            stop_this_trial <- stopTrial(
              object@stopping,
              dose = next_dose,
              samples = samples,
              model = object@model,
              data = data_current
            )

            ret <- rbind(
              ret,
              list(
                DLTsearly_1 = dlt_early,
                dose = dose,
                DLTs = num_dlts,
                nextDose = next_dose,
                stop = stop_this_trial,
                increment = as.integer(increment)
              )
            )
          }
        }
      }

      # Update previous time and compute next state.
      prev_time <- trial_time

      # Filter results at this dose with 0 DLTs and derive new dose.
      results_no_dlts <- subset(ret, dose == dose & DLTs == 0)
      new_dose <- as.numeric(results_no_dlts$nextDose)
      dose_diff <- new_dose - dose
      stop_already <- any(results_no_dlts$stop)

      # Update dose to the maximum recommended among ties.
      dose <- max(new_dose)

      # Patients still within DLT window.
      prev_size <- sum(base_data@u[base_data@y == 0] < base_data@Tmax)

      # No-increment counter and stopping due to no increment.
      no_increment_counter <- if (all(dose_diff == 0)) {
        no_increment_counter + 1L
      } else {
        0L
      }
      stop_no_increment <- (no_increment_counter >= maxNoIncrement)
      if (stop_no_increment) {
        warning(paste(
          "Stopping because",
          no_increment_counter,
          "times no increment vs. previous dose"
        ))
      }

      # Overall stop condition.
      should_stop <- (dose >= max(object@data@doseGrid)) ||
        stop_already ||
        stop_no_increment
    }

    ret
  }
)

# tidy ----

## tidy-DualDesign ----

#' @rdname tidy
#' @aliases tidy-DualDesign
#' @example examples/Design-method-tidyDualDesign.R
#'
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "DualDesign"),
  definition = function(x, ...) {
    # Some Design objects have complex attributes whose structure is not supported.
    rv <- h_tidy_all_slots(x, attributes = FALSE) %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

#' @include Simulations-class.R
#' @include helpers.R
NULL

# h_plot_simulation_trajectory ----

#' Helper Function to Create Trajectory Plot
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Creates a trajectory plot showing dose level statistics across patients.
#'
#' @param sim_doses (`list`)\cr list of simulated doses per trial.
#' @param max_patients (`integer`)\cr maximum number of patients.
#' @param has_placebo (`flag`)\cr whether the design includes placebo.
#'
#' @return A `ggplot` object.
#'
#' @keywords internal
h_plot_simulation_trajectory <- function(sim_doses, max_patients, has_placebo) {
  # Create matrix of simulated dose trajectories.
  sim_doses_mat <- matrix(
    data = NA,
    nrow = length(sim_doses),
    ncol = max_patients
  )

  for (i in seq_along(sim_doses)) {
    sim_doses_mat[i, seq_along(sim_doses[[i]])] <- sim_doses[[i]]
  }

  # Extract statistics.
  stats <- c(
    "Minimum",
    "Lower Quartile",
    "Median",
    "Upper Quartile",
    "Maximum"
  )
  traj_df <- data.frame(
    patient = rep(seq_len(max_patients), each = 5L),
    Statistic = factor(
      rep(stats, max_patients),
      levels = stats
    ),
    traj = c(apply(sim_doses_mat, 2L, quantile, na.rm = TRUE))
  )

  # Create plot title.
  my_title <- if (has_placebo) {
    "Patient (placebo were excluded)"
  } else {
    "Patient"
  }

  # Create and return plot.
  ggplot() +
    geom_step(
      aes(
        x = patient,
        y = traj,
        group = Statistic,
        linetype = Statistic
      ),
      linewidth = 1.2,
      colour = "blue",
      data = traj_df
    ) +
    xlab(my_title) +
    ylab("Dose Level")
}

# h_plot_doses_tried ----

#' Helper Function to Create Doses Tried Plot
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Creates a bar plot showing average proportions of doses tested.
#'
#' @param sim_doses (`list`)\cr list of simulated doses per trial.
#' @param dose_grid (`numeric`)\cr dose grid.
#'
#' @return A `ggplot` object.
#'
#' @keywords internal
h_plot_doses_tried <- function(sim_doses, dose_grid) {
  # Get the dose distributions by trial.
  dose_distributions <- sapply(
    sim_doses,
    function(s) {
      if (length(s) > 0) {
        prop.table(table(factor(s, levels = dose_grid)))
      } else {
        rep(0, length(dose_grid))
      }
    }
  )

  # Derive the average dose distribution across trial simulations.
  average_dose_dist <- rowMeans(dose_distributions)

  # Get in data frame shape.
  dat <- data.frame(
    dose = as.numeric(names(average_dose_dist)),
    perc = average_dose_dist * 100
  )

  # Create and return plot.
  ggplot() +
    geom_bar(
      data = dat,
      aes(x = dose, y = perc),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2
    ) +
    xlab("Dose level") +
    ylab("Average proportion [%]")
}

# plot-GeneralSimulations ----

#' Plot `GeneralSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the simulations with plots.
#'
#' This plot method can be applied to [`GeneralSimulations`] objects in order
#' to summarize them graphically. Possible `type`s of plots at the moment are:
#' \describe{
#'   \item{trajectory}{Summary of the trajectory of the simulated trials}
#'   \item{dosesTried}{Average proportions of the doses tested in patients}
#' }
#' You can specify one or both of these in the `type` argument.
#'
#' @param x (`GeneralSimulations`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the type of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is
#'   asked for, otherwise a `gtable` object.
#'
#' @aliases plot-GeneralSimulations-missing
#' @example examples/Simulations-method-plotSIMsingle.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "GeneralSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c("trajectory", "dosesTried"),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Summary of the trajectories.
    if ("trajectory" %in% type) {
      # If design with placebo, then exclude placebo patients.
      if (x@data[[1]]@placebo) {
        pl <- x@data[[1]]@doseGrid[1]
        sim_doses <- lapply(
          x@data,
          function(y) {
            y@x[y@x != pl]
          }
        )
      } else {
        sim_doses <- lapply(
          x@data,
          slot,
          "x"
        )
      }

      max_patients <- max(sapply(sim_doses, length))

      # Create trajectory plot.
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_plot_simulation_trajectory(
          sim_doses = sim_doses,
          max_patients = max_patients,
          has_placebo = x@data[[1]]@placebo
        )
    }

    # Average distribution of the doses tried.
    if ("dosesTried" %in% type) {
      # Get the doses tried.
      sim_doses <- lapply(
        x@data,
        slot,
        "x"
      )

      # Create doses tried plot.
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_plot_doses_tried(
          sim_doses = sim_doses,
          dose_grid = x@data[[1]]@doseGrid
        )
    }

    # Return plot(s).
    if (identical(length(plot_list), 1L)) {
      # Just return single plot.
      plot_list[[1L]]
    } else {
      # Otherwise arrange them.
      do.call(gridExtra::arrangeGrob, plot_list)
    }
  }
)

# plot-DualSimulations ----

#' Plot `DualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This plot method can be applied to [`DualSimulations`] objects in order to
#' summarize them graphically. In addition to the standard plot types, there is:
#' \describe{
#'   \item{sigma2W}{Plot a boxplot of the final biomarker variance estimates in
#'     the simulated trials}
#'   \item{rho}{Plot a boxplot of the final correlation estimates in the
#'     simulated trials}
#' }
#'
#' @param x (`DualSimulations`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the type of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is asked for,
#'   otherwise a `gtable` object.
#'
#' @aliases plot-DualSimulations-missing
#' @example examples/Simulations-method-plot-DualSimulations.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "DualSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c("trajectory", "dosesTried", "sigma2W", "rho"),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Subtract the specific plot types for dual-endpoint simulation results.
    type_reduced <- setdiff(type, c("sigma2W", "rho"))

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      gen_plot <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Now to the specific dual-endpoint plots.

    # Biomarker variance estimates boxplot.
    if ("sigma2W" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        ggplot(
          data = data.frame(y = x@sigma2w_est),
          aes(x = factor(0), y = y)
        ) +
        geom_boxplot() +
        coord_flip() +
        scale_x_discrete(breaks = NULL) +
        xlab("") +
        ylab("Biomarker variance estimates")
    }

    # Correlation estimates boxplot.
    if ("rho" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        ggplot(
          data = data.frame(y = x@rho_est),
          aes(x = factor(0), y = y)
        ) +
        geom_boxplot() +
        coord_flip() +
        scale_x_discrete(breaks = NULL) +
        xlab("") +
        ylab("Correlation estimates")
    }

    # Return plot(s).
    if (identical(length(plot_list), 0L)) {
      gen_plot
    } else if (identical(length(plot_list), 1L)) {
      if (more_from_general) {
        gridExtra::arrangeGrob(gen_plot, plot_list[[1L]])
      } else {
        plot_list[[1L]]
      }
    } else {
      ret <- do.call(gridExtra::arrangeGrob, plot_list)
      if (more_from_general) {
        gridExtra::arrangeGrob(gen_plot, ret)
      } else {
        ret
      }
    }
  }
)

# summary-GeneralSimulations ----

#' Summarize the `GeneralSimulations`, Relative to a Given Truth
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize simulations relative to a given true dose-toxicity curve.
#'
#' @param object (`GeneralSimulations`)\cr the object we want to summarize.
#' @param truth (`function`)\cr a function which takes as input a dose (vector)
#'   and returns the true probability (vector) for toxicity.
#' @param target (`numeric`)\cr the target toxicity interval (default: 20-35%)
#'   used for the computations.
#' @param ... additional arguments can be supplied here for `truth`.
#'
#' @return An object of class [`GeneralSimulationsSummary`].
#'
#' @aliases summary-GeneralSimulations
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "GeneralSimulations"),
  def = function(object, truth, target = c(0.2, 0.35), ...) {
    # Validate arguments.
    assert_function(truth)
    assert_numeric(target, min.len = 1, max.len = 2, lower = 0, upper = 1)
    if (length(target) == 2) {
      assert_true(target[1] < target[2])
    }

    # Extract dose grid.
    dose_grid <- object@data[[1]]@doseGrid

    # Evaluate true toxicity at dose grid.
    true_tox <- truth(dose_grid, ...)

    # Find dose interval corresponding to target tox interval.
    target_dose_interval <- sapply(
      target,
      function(t) {
        # We have to be careful because it might be that in the range of the
        # dose grid, no doses can be found that match the target interval
        # boundaries! In that case we want to return NA.
        r <- try(
          uniroot(
            f = function(x) {
              truth(x, ...) - t
            },
            interval = range(dose_grid)
          )$root,
          silent = TRUE
        )
        if (inherits(r, "try-error")) {
          NA_real_
        } else {
          r
        }
      }
    )

    # What are the levels above target interval?
    x_above_target <- which(true_tox > target[2])

    # Proportion of DLTs in a trial.
    if (object@data[[1]]@placebo) {
      if (sum(object@data[[1]]@x == dose_grid[1])) {
        prop_dlts <- sapply(
          object@data,
          function(d) {
            tapply(
              d@y,
              factor(d@x == d@doseGrid[1], labels = c("ACTV", "PLCB")),
              mean
            )
          }
        )
      } else {
        prop_dlts <- sapply(
          object@data,
          function(d) {
            c("ACTV" = mean(d@y), "PLCB" = NA)
          }
        )
      }
    } else {
      prop_dlts <- sapply(
        object@data,
        function(d) {
          mean(d@y)
        }
      )
    }

    # Mean toxicity risk.
    if (object@data[[1]]@placebo) {
      mean_tox_risk <- sapply(
        object@data,
        function(d) {
          mean(true_tox[d@xLevel[d@xLevel != 1]])
        }
      )
    } else {
      mean_tox_risk <- sapply(
        object@data,
        function(d) {
          mean(true_tox[d@xLevel])
        }
      )
    }

    # Doses selected for MTD.
    dose_selected <- object@doses

    # Replace NA by 0.
    dose_selected[is.na(dose_selected)] <- 0

    # Dose most often selected as MTD.
    dose_most_selected <- as.numeric(names(which.max(table(dose_selected))))
    x_most_selected <- match_within_tolerance(
      dose_most_selected,
      table = dose_grid
    )

    # Observed toxicity rate at dose most often selected.
    # Note: this does not seem very useful!
    # Reason: In case of a fine grid, few patients if any will have been
    # treated at this dose.
    tmp <- sapply(
      object@data,
      function(d) {
        which_at_this_dose <- which(d@x == dose_most_selected)
        n_at_this_dose <- length(which_at_this_dose)
        n_dlt_at_this_dose <- sum(d@y[which_at_this_dose])
        c(
          nAtThisDose = n_at_this_dose,
          nDLTatThisDose = n_dlt_at_this_dose
        )
      }
    )

    obs_tox_rate_at_dose_most_selected <-
      mean(tmp["nDLTatThisDose", ]) / mean(tmp["nAtThisDose", ])

    # Number of patients overall.
    if (object@data[[1]]@placebo) {
      n_obs <- sapply(
        object@data,
        function(x) {
          data.frame(
            n.ACTV = sum(x@xLevel != 1L),
            n.PLCB = sum(x@xLevel == 1L)
          )
        }
      )
      n_obs <- matrix(unlist(n_obs), dim(n_obs))
    } else {
      n_obs <- sapply(
        object@data,
        slot,
        "nObs"
      )
    }

    # Number of patients treated above target tox interval.
    n_above_target <- sapply(
      object@data,
      function(d) {
        sum(d@xLevel %in% x_above_target)
      }
    )

    # Proportion of trials selecting target MTD.
    tox_at_doses <- truth(dose_selected, ...)
    prop_at_target <- mean(
      (tox_at_doses > target[1]) & (tox_at_doses < target[2])
    )

    # Give back an object of class GeneralSimulationsSummary.
    .GeneralSimulationsSummary(
      target = target,
      target_dose_interval = target_dose_interval,
      nsim = length(object@data),
      prop_dlts = prop_dlts,
      mean_tox_risk = mean_tox_risk,
      dose_selected = dose_selected,
      dose_most_selected = dose_most_selected,
      obs_tox_rate_at_dose_most_selected = obs_tox_rate_at_dose_most_selected,
      n_obs = n_obs,
      n_above_target = n_above_target,
      tox_at_doses_selected = tox_at_doses,
      prop_at_target = prop_at_target,
      dose_grid = dose_grid,
      placebo = object@data[[1]]@placebo
    )
  }
)

# summary-Simulations ----

#' Summarize Model-Based Design Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the model-based design simulations, relative to a given truth.
#'
#' @param object (`Simulations`)\cr the object we want to summarize.
#' @param truth (`function`)\cr a function which takes as input a dose (vector)
#'   and returns the true probability (vector) for toxicity.
#' @param target (`numeric`)\cr the target toxicity interval (default: 20-35%)
#'   used for the computations.
#' @param ... additional arguments can be supplied here for `truth`.
#'
#' @return An object of class [`SimulationsSummary`].
#'
#' @aliases summary-Simulations
#' @example examples/Simulations-method-summary.R
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "Simulations"),
  def = function(object, truth, target = c(0.2, 0.35), ...) {
    # Call the parent method.
    start <- callNextMethod(
      object = object,
      truth = truth,
      target = target,
      ...
    )

    dose_grid <- object@data[[1]]@doseGrid

    # Dose level most often selected as MTD.
    x_most_selected <-
      match_within_tolerance(start@dose_most_selected, table = dose_grid)

    # Fitted toxicity rate at dose most often selected.
    fit_at_dose_most_selected <-
      sapply(
        object@fit,
        function(f) {
          f$middle[x_most_selected]
        }
      )

    # Mean fitted toxicity (average, lower and upper quantiles)
    # at each dose level (this is required for plotting).
    mean_fit_matrix <- sapply(
      object@fit,
      "[[",
      "middle"
    )
    mean_fit <- list(
      truth = truth(dose_grid, ...),
      average = rowMeans(mean_fit_matrix),
      lower = apply(
        mean_fit_matrix,
        1L,
        quantile,
        0.025
      ),
      upper = apply(
        mean_fit_matrix,
        1L,
        quantile,
        0.975
      )
    )

    # Give back an object of class SimulationsSummary.
    .SimulationsSummary(
      start,
      stop_report = object@stop_report,
      additional_stats = object@additional_stats,
      fit_at_dose_most_selected = fit_at_dose_most_selected,
      mean_fit = mean_fit
    )
  }
)

# summary-DualSimulations ----

#' Summarize Dual-Endpoint Design Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the dual-endpoint design simulations, relative to given true
#' dose-toxicity and dose-biomarker curves.
#'
#' @param object (`DualSimulations`)\cr the object we want to summarize.
#' @param trueTox (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the true probability (vector) for toxicity.
#' @param trueBiomarker (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the true biomarker level (vector).
#' @param target (`numeric`)\cr the target toxicity interval (default: 20-35%)
#'   used for the computations.
#' @param ... additional arguments can be supplied here for `trueTox` and
#'   `trueBiomarker`.
#'
#' @return An object of class [`DualSimulationsSummary`].
#'
#' @aliases summary-DualSimulations
#' @example examples/Simulations-method-summary-DualSimulations.R
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "DualSimulations"),
  def = function(object, trueTox, trueBiomarker, target = c(0.2, 0.35), ...) {
    # Call the parent method.
    start <- callNextMethod(
      object = object,
      truth = trueTox,
      target = target,
      ...
    )

    dose_grid <- object@data[[1]]@doseGrid

    # Dose level most often selected as MTD.
    x_most_selected <-
      match_within_tolerance(start@dose_most_selected, table = dose_grid)

    # Fitted biomarker level at dose most often selected.
    biomarker_fit_at_dose_most_selected <-
      sapply(
        object@fit_biomarker,
        function(f) {
          f$middleBiomarker[x_most_selected]
        }
      )

    # Mean fitted biomarker curve (average, lower and upper quantiles)
    # at each dose level (this is required for plotting).
    mean_biomarker_fit_matrix <- sapply(
      object@fit_biomarker,
      "[[",
      "middleBiomarker"
    )
    mean_biomarker_fit <- list(
      truth = trueBiomarker(dose_grid, ...),
      average = rowMeans(mean_biomarker_fit_matrix),
      lower = apply(
        mean_biomarker_fit_matrix,
        1L,
        quantile,
        0.025
      ),
      upper = apply(
        mean_biomarker_fit_matrix,
        1L,
        quantile,
        0.975
      )
    )

    # Give back an object of class DualSimulationsSummary.
    .DualSimulationsSummary(
      start,
      biomarker_fit_at_dose_most_selected = biomarker_fit_at_dose_most_selected,
      mean_biomarker_fit = mean_biomarker_fit
    )
  }
)

# Report-class ----

#' @field object The object from which to report
#' @field df the data frame to which columns are sequentially added
#' @field dfNames the names to which strings are sequentially added
Report <-
  setRefClass(
    "Report",
    fields = list(
      object = "ANY",
      df = "data.frame",
      dfNames = "character"
    ),
    methods = list(
      dfSave = function(res, name) {
        df <<- cbind(df, res)
        dfNames <<- c(dfNames, name)
        res
      },
      report = function(
        slotName,
        description,
        percent = TRUE,
        digits = 0,
        quantiles = c(0.1, 0.9),
        subset = NULL,
        doSum = FALSE
      ) {
        vals <- slot(object, name = slotName)
        if (!is.null(subset)) {
          vals <- vals[subset, ]
        }
        if (doSum) {
          vals <- apply(vals, 2, sum)
        }
        if (percent) {
          unit <- " %"
          vals <- vals * 100
        } else {
          unit <- ""
        }

        res <- paste(
          round(mean(vals), digits),
          unit,
          " (",
          paste(
            round(
              quantile(vals, quantiles, na.rm = TRUE),
              digits
            ),
            unit,
            collapse = ", ",
            sep = ""
          ),
          ")",
          sep = ""
        )

        # Print result to the buffer.
        cat(
          description,
          ":",
          "mean",
          dfSave(res, slotName),
          "\n"
        )
      }
    )
  )

# show-GeneralSimulationsSummary ----

#' Show the Summary of the Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of general simulation results.
#'
#' @param object (`GeneralSimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'   appropriate column names.
#'
#' @aliases show-GeneralSimulationsSummary
#' @export
#'
setMethod(
  f = "show",
  signature = signature(object = "GeneralSimulationsSummary"),
  def = function(object) {
    r <- Report$new(
      object = object,
      df = as.data.frame(matrix(
        nrow = 1,
        ncol = 0
      )),
      dfNames = character()
    )

    cat(
      "Summary of",
      r$dfSave(object@nsim, "nsim"),
      "simulations\n\n"
    )

    cat(
      "Target toxicity interval was",
      r$dfSave(
        paste(round(object@target * 100), collapse = ", "),
        "target"
      ),
      "%\n"
    )
    cat(
      "Target dose interval corresponding to this was",
      r$dfSave(
        paste(round(object@target_dose_interval, 1), collapse = ", "),
        "target_dose_interval"
      ),
      "\n"
    )
    cat(
      "Intervals are corresponding to",
      "10 and 90 % quantiles\n\n"
    )

    if (object@placebo) {
      r$report(
        "n_obs",
        "Number of patients on placebo",
        percent = FALSE,
        subset = 2
      )
      r$report(
        "n_obs",
        "Number of patients on active",
        percent = FALSE,
        subset = 1
      )
      r$report(
        "n_obs",
        "Number of patients overall",
        percent = FALSE,
        doSum = TRUE
      )
    } else {
      r$report("n_obs", "Number of patients overall", percent = FALSE)
    }
    r$report(
      "n_above_target",
      "Number of patients treated above target tox interval",
      percent = FALSE
    )

    if (object@placebo) {
      r$report(
        "prop_dlts",
        "Proportions of DLTs in the trials for patients on placebo",
        subset = 2
      )
      r$report(
        "prop_dlts",
        "Proportions of DLTs in the trials for patients on active",
        subset = 1
      )
    } else {
      r$report(
        "prop_dlts",
        "Proportions of DLTs in the trials"
      )
    }
    r$report(
      "mean_tox_risk",
      "Mean toxicity risks for the patients on active"
    )
    r$report(
      "dose_selected",
      "Doses selected as MTD",
      percent = FALSE,
      digits = 1
    )
    r$report(
      "tox_at_doses_selected",
      "True toxicity at doses selected"
    )
    cat(
      "Proportion of trials selecting target MTD:",
      r$dfSave(
        object@prop_at_target * 100,
        "prop_at_target"
      ),
      "%\n"
    )
    cat(
      "Dose most often selected as MTD:",
      r$dfSave(
        object@dose_most_selected,
        "dose_most_selected"
      ),
      "\n"
    )
    cat(
      "Observed toxicity rate at dose most often selected:",
      r$dfSave(
        round(object@obs_tox_rate_at_dose_most_selected * 100),
        "obs_tox_rate_at_dose_most_selected"
      ),
      "%\n"
    )

    # Finally assign names to the df and return it invisibly.
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)

# show-SimulationsSummary ----

#' Show the Summary of Model-Based Design Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of model-based design simulation results.
#'
#' @param object (`SimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'   appropriate column names.
#'
#' @aliases show-SimulationsSummary
#' @example examples/Simulations-method-show-SimulationsSummary.R
#' @export
#'
setMethod(
  f = "show",
  signature = signature(object = "SimulationsSummary"),
  def = function(object) {
    # Call the parent method.
    df <- callNextMethod(object)
    df_names <- names(df)

    # Start report object.
    r <- Report$new(
      object = object,
      df = df,
      dfNames = df_names
    )

    # Add one reporting line.
    r$report(
      "fit_at_dose_most_selected",
      "Fitted toxicity rate at dose most often selected"
    )

    # Report results of additional statistics summary.
    if (length(unlist(object@additional_stats)) > 0) {
      param_names <- h_summarize_add_stats(
        stats_list = object@additional_stats
      )[[1]]
      averages <- h_summarize_add_stats(stats_list = object@additional_stats)[[
        2
      ]]

      for (i in seq_along(param_names)) {
        cat(param_names[i], ":", round(averages[[i]], 2), "\n")
      }
    }

    # Report individual stopping rules with non-NA labels.
    stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

    if (length(stop_pct_to_print) > 0) {
      cat(
        "Stop reason triggered:\n",
        paste(
          names(stop_pct_to_print),
          ": ",
          round(stop_pct_to_print, 2),
          "%\n"
        )
      )
    }

    # And return the updated information.
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)

# show-DualSimulationsSummary ----

#' Show the Summary of Dual-Endpoint Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of dual-endpoint simulation results.
#'
#' @param object (`DualSimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'   appropriate column names.
#'
#' @aliases show-DualSimulationsSummary
#' @example examples/Simulations-method-show-DualSimulationsSummary.R
#' @export
#'
setMethod(
  f = "show",
  signature = signature(object = "DualSimulationsSummary"),
  def = function(object) {
    # Call the parent method.
    df <- callNextMethod(object)
    df_names <- names(df)

    # Start report object.
    r <- Report$new(
      object = object,
      df = df,
      dfNames = df_names
    )

    # Add one reporting line.
    r$report(
      "biomarker_fit_at_dose_most_selected",
      "Fitted biomarker level at dose most often selected",
      percent = FALSE,
      digits = 1
    )

    # And return the updated information.
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)

# plot-GeneralSimulationsSummary ----

#' Plot `GeneralSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Graphical display of the general simulation summary.
#'
#' This plot method can be applied to [`GeneralSimulationsSummary`] objects in
#' order to summarize them graphically. Possible `type`s of plots at the moment
#' are:
#' \describe{
#'   \item{nObs}{Distribution of the number of patients in the simulated trials}
#'   \item{doseSelected}{Distribution of the final selected doses in the trials.
#'     Note that this can include zero entries, meaning that the trial was
#'     stopped because all doses in the dose grid appeared too toxic.}
#'   \item{propDLTs}{Distribution of the proportion of patients with DLTs in the
#'     trials}
#'   \item{nAboveTarget}{Distribution of the number of patients treated at doses
#'     which are above the target toxicity interval (as specified by the
#'     `truth` and `target` arguments to [`summary,GeneralSimulations-method`])}
#' }
#' You can specify any subset of these in the `type` argument.
#'
#' @param x (`GeneralSimulationsSummary`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is
#'   asked for, otherwise a `gtable` object.
#'
#' @aliases plot-GeneralSimulationsSummary-missing
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "GeneralSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLTs",
      "nAboveTarget"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Distribution of overall sample size.
    if (x@placebo) {
      if ("nObs" %in% type) {
        plot_list[[plot_index <- plot_index + 1L]] <-
          h_barplot_percentages(
            x = x@n_obs[2, ],
            description = "Number of patients on active in total"
          )
      }
    } else {
      if ("nObs" %in% type) {
        plot_list[[plot_index <- plot_index + 1L]] <-
          h_barplot_percentages(
            x = x@n_obs,
            description = "Number of patients in total"
          )
      }
    }

    # Distribution of final MTD estimate.
    if ("doseSelected" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_barplot_percentages(
          x = x@dose_selected,
          description = "MTD estimate"
        )
    }

    # Distribution of proportion of DLTs.
    if (x@placebo) {
      if ("propDLTs" %in% type) {
        plot_list[[plot_index <- plot_index + 1L]] <-
          h_barplot_percentages(
            x = x@prop_dlts[1, ] * 100,
            description = "Proportion of DLTs [%] on active",
            xaxisround = 1
          )
      }
    } else {
      if ("propDLTs" %in% type) {
        plot_list[[plot_index <- plot_index + 1L]] <-
          h_barplot_percentages(
            x = x@prop_dlts * 100,
            description = "Proportion of DLTs [%]",
            xaxisround = 1
          )
      }
    }

    # Distribution of number of patients treated at too much tox.
    if ("nAboveTarget" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_barplot_percentages(
          x = x@n_above_target,
          description = "Number of patients above target"
        )
    }

    # First combine these small plots.
    if (length(plot_list)) {
      ret <-
        # If there is only one plot.
        if (identical(length(plot_list), 1L)) {
          # Just use that.
          plot_list[[1L]]
        } else {
          # Multiple plots in this case.
          do.call(
            gridExtra::arrangeGrob,
            plot_list
          )
        }
    }

    # Then return.
    ret
  }
)

# plot-SimulationsSummary ----

#' Plot Model-Based Design Simulation Summary
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Graphical display of the simulation summary.
#'
#' This plot method can be applied to [`SimulationsSummary`] objects in order
#' to summarize them graphically. Possible `type` of plots at the moment are
#' those listed in [`plot,GeneralSimulationsSummary,missing-method`] plus:
#'
#' \describe{
#'   \item{meanFit}{Plot showing the average fitted dose-toxicity curve across
#'     the trials, together with 95% credible intervals, and comparison with the
#'     assumed truth (as specified by the `truth` argument to
#'     [`summary,Simulations-method`])}
#' }
#'
#' You can specify any subset of these in the `type` argument.
#'
#' @param x (`SimulationsSummary`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is
#'   asked for, otherwise a `gtable` object.
#'
#' @aliases plot-SimulationsSummary-missing
#' @example examples/Simulations-method-plot-SimulationsSummary.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "SimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLTs",
      "nAboveTarget",
      "meanFit"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Subtract the specific plot types for model-based designs.
    type_reduced <- setdiff(
      type,
      "meanFit"
    )

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      ret <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Is the meanFit plot requested?
    if ("meanFit" %in% type) {
      # Which types of lines do we have?
      linetype <- c(
        "True toxicity",
        "Average estimated toxicity",
        "95% interval for estimated toxicity"
      )

      # Create the data frame, with true tox, average estimated tox, and 95%
      # (lower, upper) estimated tox (in percentage) stacked below each other.
      dat <- data.frame(
        dose = rep(x@dose_grid, 4L),
        group = rep(1:4, each = length(x@dose_grid)),
        linetype = factor(
          rep(linetype[c(1, 2, 3, 3)], each = length(x@dose_grid)),
          levels = linetype
        ),
        lines = unlist(x@mean_fit) * 100
      )

      # Linetypes for the plot.
      lt <- c(
        "True toxicity" = 1,
        "Average estimated toxicity" = 1,
        "95% interval for estimated toxicity" = 2
      )

      # Colour for the plot.
      col <- c(
        "True toxicity" = 1,
        "Average estimated toxicity" = 2,
        "95% interval for estimated toxicity" = 2
      )

      # Now create and save the plot.
      this_plot <- ggplot() +
        geom_line(
          aes(
            x = dose,
            y = lines,
            group = group,
            linetype = linetype,
            col = linetype
          ),
          data = dat
        )

      this_plot <- this_plot +
        scale_linetype_manual(values = lt) +
        scale_colour_manual(values = col) +
        xlab("Dose level") +
        ylab("Probability of DLT [%]")

      # Add this plot to the bottom.
      ret <-
        if (more_from_general) {
          gridExtra::arrangeGrob(ret, this_plot)
        } else {
          this_plot
        }
    }

    # Then finally plot everything.
    ret
  }
)

# plot-DualSimulationsSummary ----

#' Plot Dual-Endpoint Design Simulation Summary
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Graphical display of dual-endpoint simulation summary.
#'
#' This plot method can be applied to [`DualSimulationsSummary`] objects in
#' order to summarize them graphically. Possible `type` of plots at the moment
#' are those listed in [`plot,SimulationsSummary,missing-method`] plus:
#'
#' \describe{
#'   \item{meanBiomarkerFit}{Plot showing the average fitted dose-biomarker
#'     curve across the trials, together with 95% credible intervals, and
#'     comparison with the assumed truth (as specified by the `trueBiomarker`
#'     argument to [`summary,DualSimulations-method`])}
#' }
#'
#' You can specify any subset of these in the `type` argument.
#'
#' @param x (`DualSimulationsSummary`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is
#'   asked for, otherwise a `gtable` object.
#'
#' @aliases plot-DualSimulationsSummary-missing
#' @example examples/Simulations-method-plot-DualSimulationsSummary.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "DualSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLTs",
      "nAboveTarget",
      "meanFit",
      "meanBiomarkerFit"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Subtract the specific plot types for dual-endpoint designs.
    type_reduced <- setdiff(
      type,
      "meanBiomarkerFit"
    )

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      ret <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Is the meanBiomarkerFit plot requested?
    if ("meanBiomarkerFit" %in% type) {
      # Which types of lines do we have?
      linetype <- c(
        "True biomarker",
        "Average estimated biomarker",
        "95% interval for estimated biomarker"
      )

      # Create the data frame, with true biomarker, average estimated
      # biomarker, and 95% (lower, upper) estimated biomarker stacked below
      # each other.
      dat <- data.frame(
        dose = rep(x@dose_grid, 4L),
        group = rep(1:4, each = length(x@dose_grid)),
        linetype = factor(
          rep(linetype[c(1, 2, 3, 3)], each = length(x@dose_grid)),
          levels = linetype
        ),
        lines = unlist(x@mean_biomarker_fit)
      )

      # Linetypes for the plot.
      lt <- c(
        "True biomarker" = 1,
        "Average estimated biomarker" = 1,
        "95% interval for estimated biomarker" = 2
      )

      # Colour for the plot.
      col <- c(
        "True biomarker" = 1,
        "Average estimated biomarker" = 2,
        "95% interval for estimated biomarker" = 2
      )

      # Now create and save the plot.
      this_plot <- ggplot() +
        geom_line(
          aes(
            x = dose,
            y = lines,
            group = group,
            linetype = linetype,
            col = linetype
          ),
          data = dat
        )

      this_plot <- this_plot +
        scale_linetype_manual(values = lt) +
        scale_colour_manual(values = col) +
        xlab("Dose level") +
        ylab("Biomarker level")

      # Add this plot to the bottom.
      ret <-
        if (more_from_general) {
          gridExtra::arrangeGrob(ret, this_plot, heights = c(2 / 3, 1 / 3))
        } else {
          this_plot
        }
    }

    # Then finally plot everything.
    ret
  }
)

# h_pseudo_sim_inverse_dose ----

#' Helper Function to Calculate Inverse Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Creates an inverse function to find the dose corresponding to a target
#' probability.
#'
#' @param f (`function`)\cr the truth function mapping dose to probability.
#' @param lower (`number`)\cr lower bound for root finding.
#' @param upper (`number`)\cr upper bound for root finding.
#'
#' @return A function that takes a probability and returns the corresponding
#'   dose.
#'
#' @keywords internal
h_pseudo_sim_inverse_dose <- function(f, lower = -100, upper = 100) {
  function(y) {
    uniroot((function(x) f(x) - y), lower = lower, upper = upper)[1]
  }
}

# h_pseudo_sim_fit_summary ----

#' Helper Function to Calculate Fit Summary
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Calculates fit summary statistics for pseudo simulations.
#'
#' @param fit_list (`list`)\cr list of fit objects from simulations.
#' @param x_most_selected (`integer`)\cr index of dose most often selected.
#' @param dose_grid (`numeric`)\cr dose grid.
#' @param truth (`function`)\cr truth function.
#'
#' @return A list with `fit_at_dose_most_selected` and `mean_fit` components.
#'
#' @keywords internal
h_pseudo_sim_fit_summary <- function(
  fit_list,
  x_most_selected,
  dose_grid,
  truth
) {
  # Find names in the fit list (check if with or without samples).
  fit_names <- sapply(fit_list, names)

  if ("probDLE" %in% fit_names) {
    fit_at_dose_most_selected <- sapply(
      fit_list,
      function(f) {
        f$probDLE[x_most_selected]
      }
    )
    mean_fit_matrix <- sapply(
      fit_list,
      "[[",
      "probDLE"
    )

    mean_fit <- list(
      truth = truth(dose_grid),
      average = rowMeans(mean_fit_matrix)
    )
  } else {
    fit_at_dose_most_selected <-
      sapply(
        fit_list,
        function(f) {
          f$middle[x_most_selected]
        }
      )

    # Mean fitted toxicity (average, lower and upper quantiles) at each dose
    # level (this is required for plotting).
    mean_fit_matrix <- sapply(
      fit_list,
      "[[",
      "middle"
    )
    mean_fit <- list(
      truth = truth(dose_grid),
      average = rowMeans(mean_fit_matrix),
      lower = apply(
        mean_fit_matrix,
        1L,
        quantile,
        0.025
      ),
      upper = apply(
        mean_fit_matrix,
        1L,
        quantile,
        0.975
      )
    )
  }

  list(
    fit_at_dose_most_selected = fit_at_dose_most_selected,
    mean_fit = mean_fit
  )
}

# summary-PseudoSimulations ----

#' Summarize `PseudoSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the simulations, relative to a given truth.
#'
#' @param object (`PseudoSimulations`)\cr the object we want to summarize.
#' @param truth (`function`)\cr a function which takes as input a dose (vector)
#'   and returns the true probability (vector) for toxicity.
#' @param targetEndOfTrial (`number`)\cr the target probability of DLE wanted
#'   to achieve at the end of a trial.
#' @param targetDuringTrial (`number`)\cr the target probability of DLE wanted
#'   to achieve during a trial.
#' @param ... additional arguments can be supplied here for `truth`.
#'
#' @return An object of class [`PseudoSimulationsSummary`].
#'
#' @aliases summary-PseudoSimulations
#' @example examples/Simulations-method-summarySIMsingle.R
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "PseudoSimulations"),
  def = function(
    object,
    truth,
    targetEndOfTrial = 0.3,
    targetDuringTrial = 0.35,
    ...
  ) {
    # Validate arguments.
    assert_function(truth)
    assert_number(targetEndOfTrial, lower = 0, upper = 1)
    assert_number(targetDuringTrial, lower = 0, upper = 1)

    # Extract dose grid.
    dose_grid <- object@data[[1]]@doseGrid

    # Evaluate true DLE at dose grid.
    true_dle <- truth(dose_grid)

    # Function to obtain corresponding dose level given target prob.
    td <- h_pseudo_sim_inverse_dose(truth, 0, max(dose_grid))

    # Find the dose corresponding to the target dose during trial.
    target_dose_end_of_trial <- as.numeric(td(targetEndOfTrial))

    # Find the dose corresponding to the target dose end of trial.
    target_dose_during_trial <- as.numeric(td(targetDuringTrial))

    # Find the dose at dose grid corresponding to the above two quantities.
    target_dose_end_of_trial_at_dose_grid <- dose_grid[max(which(
      target_dose_end_of_trial - dose_grid >= 0
    ))]
    target_dose_during_trial_at_dose_grid <- dose_grid[max(which(
      target_dose_during_trial - dose_grid >= 0
    ))]

    # A summary for all TDtargetEndOfTrial dose obtained.
    tdeot_summary <- summary(object@final_td_target_end_of_trial_estimates)

    final_dose_rec_summary <- tdeot_summary

    ratio_tdeot_summary <- summary(object@final_tdeot_ratios)
    final_ratio_summary <- ratio_tdeot_summary

    # A summary for all TDtargetDuringTrial dose obtained.
    tddt_summary <- summary(object@final_td_target_during_trial_estimates)

    # What are the levels above target End of Trial?
    x_above_target_end_of_trial <- which(true_dle > targetEndOfTrial)

    # What are the levels above target During Trial?
    x_above_target_during_trial <- which(true_dle > targetDuringTrial)

    # Proportion of DLEs in this trial.
    prop_dle <- sapply(
      object@data,
      function(d) {
        mean(d@y)
      }
    )

    # Mean toxicity risk.
    mean_tox_risk <- sapply(
      object@data,
      function(d) {
        mean(true_dle[d@xLevel])
      }
    )

    # Doses selected for MTD.
    dose_selected <- object@doses

    # Replace NA by 0.
    dose_selected[is.na(dose_selected)] <- 0

    # Dose most often selected as MTD.
    dose_most_selected <-
      as.numeric(names(which.max(table(dose_selected))))

    x_most_selected <-
      match_within_tolerance(dose_most_selected, table = dose_grid)

    # Observed toxicity rate at dose most often selected.
    # Note: this does not seem very useful!
    # Reason: In case of a fine grid, few patients if any will have been
    # treated at this dose.
    tmp <-
      sapply(
        object@data,
        function(d) {
          which_at_this_dose <- which(d@x == dose_most_selected)
          n_at_this_dose <- length(which_at_this_dose)
          n_dlt_at_this_dose <- sum(d@y[which_at_this_dose])
          c(
            nAtThisDose = n_at_this_dose,
            nDLTatThisDose = n_dlt_at_this_dose
          )
        }
      )

    obs_tox_rate_at_dose_most_selected <-
      mean(tmp["nDLTatThisDose", ]) / mean(tmp["nAtThisDose", ])

    # Number of patients overall.
    n_obs <- sapply(
      object@data,
      slot,
      "nObs"
    )

    # Number of patients treated above target End of trial.
    n_above_target_end_of_trial <- sapply(
      object@data,
      function(d) {
        sum(d@xLevel %in% x_above_target_end_of_trial)
      }
    )

    # Number of patients treated above target During trial.
    n_above_target_during_trial <- sapply(
      object@data,
      function(d) {
        sum(d@xLevel %in% x_above_target_during_trial)
      }
    )

    tox_at_doses <- truth(dose_selected)

    # Proportion of trials selecting target TDEndOfTrial and TDDuringTrial.
    nsim <- length(object@data)

    prop_at_target_end_of_trial <- (length(which(
      object@doses == target_dose_end_of_trial_at_dose_grid
    ))) /
      nsim

    prop_at_target_during_trial <- (length(which(
      object@doses == target_dose_during_trial_at_dose_grid
    ))) /
      nsim

    # Calculate fit summary using helper function.
    fit_summary <- h_pseudo_sim_fit_summary(
      fit_list = object@fit,
      x_most_selected = x_most_selected,
      dose_grid = dose_grid,
      truth = truth
    )

    # Give back an object of class PseudoSimulationsSummary.
    .PseudoSimulationsSummary(
      target_end_of_trial = targetEndOfTrial,
      target_dose_end_of_trial = target_dose_end_of_trial,
      target_during_trial = targetDuringTrial,
      target_dose_during_trial = target_dose_during_trial,
      target_dose_end_of_trial_at_dose_grid = target_dose_end_of_trial_at_dose_grid,
      target_dose_during_trial_at_dose_grid = target_dose_during_trial_at_dose_grid,
      tdeot_summary = tdeot_summary,
      tddt_summary = tddt_summary,
      final_dose_rec_summary = final_dose_rec_summary,
      ratio_tdeot_summary = ratio_tdeot_summary,
      final_ratio_summary = final_ratio_summary,
      nsim = nsim,
      prop_dle = prop_dle,
      mean_tox_risk = mean_tox_risk,
      dose_selected = dose_selected,
      dose_most_selected = dose_most_selected,
      obs_tox_rate_at_dose_most_selected = obs_tox_rate_at_dose_most_selected,
      n_obs = n_obs,
      n_above_target_end_of_trial = n_above_target_end_of_trial,
      n_above_target_during_trial = n_above_target_during_trial,
      tox_at_doses_selected = tox_at_doses,
      prop_at_target_end_of_trial = prop_at_target_end_of_trial,
      prop_at_target_during_trial = prop_at_target_during_trial,
      dose_grid = dose_grid,
      fit_at_dose_most_selected = fit_summary$fit_at_dose_most_selected,
      stop_report = object@stop_report,
      mean_fit = fit_summary$mean_fit
    )
  }
)

# show-PseudoSimulationsSummary ----

#' Show the Summary of `PseudoSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of pseudo simulation results.
#'
#' @param object (`PseudoSimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'   appropriate column names.
#'
#' @aliases show-PseudoSimulationsSummary
#' @example examples/Simulations-method-showSIMsingle.R
#' @export
#'
setMethod(
  f = "show",
  signature = signature(object = "PseudoSimulationsSummary"),
  def = function(object) {
    r <- Report$new(
      object = object,
      df = as.data.frame(matrix(
        nrow = 1,
        ncol = 0
      )),
      dfNames = character()
    )
    cat(
      "Summary of",
      r$dfSave(object@nsim, "nsim"),
      "simulations\n\n"
    )

    cat(
      "Target probability of DLE p(DLE) used at the end of a trial was",
      r$dfSave(
        object@target_end_of_trial * 100,
        "target_end_of_trial"
      ),
      "%\n"
    )

    cat(
      "The dose level corresponds to the target p(DLE) used at the end of a trial, TDEOT, was",
      r$dfSave(
        object@target_dose_end_of_trial,
        "target_dose_end_of_trial"
      ),
      "\n"
    )
    cat(
      "TDEOT at dose Grid was",
      r$dfSave(
        object@target_dose_end_of_trial_at_dose_grid,
        "target_dose_end_of_trial_at_dose_grid"
      ),
      "\n"
    )

    cat(
      "Target p(DLE) used during a trial was",
      r$dfSave(
        object@target_during_trial * 100,
        "target_during_trial"
      ),
      "%\n"
    )

    cat(
      "The dose level corresponds to the target p(DLE) used during a trial, TDDT, was",
      r$dfSave(
        object@target_dose_during_trial,
        "target_dose_during_trial"
      ),
      "\n"
    )

    cat(
      "TDDT at dose Grid was",
      r$dfSave(
        object@target_dose_during_trial_at_dose_grid,
        "target_dose_during_trial_at_dose_grid"
      ),
      "\n"
    )

    r$report("n_obs", "Number of patients overall", percent = FALSE)
    r$report(
      "n_above_target_end_of_trial",
      "Number of patients treated above the target p(DLE) used at the end of a trial",
      percent = FALSE
    )

    r$report(
      "n_above_target_during_trial",
      "Number of patients treated above the target p(DLE) used during a trial",
      percent = FALSE
    )

    r$report(
      "prop_dle",
      "Proportions of observed DLT in the trials"
    )
    r$report(
      "mean_tox_risk",
      "Mean toxicity risks for the patients"
    )
    r$report(
      "dose_selected",
      "Doses selected as TDEOT",
      percent = FALSE,
      digits = 1
    )

    r$report(
      "tox_at_doses_selected",
      "True toxicity at TDEOT"
    )

    cat(
      "Proportion of trials selecting the TDEOT:",
      r$dfSave(
        object@prop_at_target_end_of_trial * 100,
        "percentAtTarget"
      ),
      "%\n"
    )

    cat(
      "Proportion of trials selecting the TDDT:",
      r$dfSave(
        object@prop_at_target_during_trial * 100,
        "percentAtTarget"
      ),
      "%\n"
    )

    cat(
      "Dose most often selected as TDEOT:",
      r$dfSave(
        object@dose_most_selected,
        "doseMostSelected"
      ),
      "\n"
    )
    cat(
      "Observed toxicity rate at dose most often selected:",
      r$dfSave(
        round(object@obs_tox_rate_at_dose_most_selected * 100),
        "obsToxRateAtDoseMostSelected"
      ),
      "%\n"
    )
    r$report(
      "fit_at_dose_most_selected",
      "Fitted probabilities of DLE at dose most often selected"
    )

    TDEOTSum <- object@tdeot_summary

    r$dfSave(as.numeric(TDEOTSum[1]), "TDEOTMin")
    r$dfSave(as.numeric(TDEOTSum[2]), "TDEOTlower")
    r$dfSave(as.numeric(TDEOTSum[3]), "TDEOTMedian")
    r$dfSave(as.numeric(TDEOTSum[4]), "TDEOTMean")
    r$dfSave(as.numeric(TDEOTSum[5]), "TDEOTUpper")
    r$dfSave(as.numeric(TDEOTSum[6]), "TDEOTMax")

    cat(
      "The summary table of the final TDEOT across all simulations\n",
      capture.output(TDEOTSum)[1],
      "\n",
      capture.output(TDEOTSum)[2],
      "\n"
    )

    ratioTDEOTSum <- object@ratio_tdeot_summary

    r$dfSave(as.numeric(ratioTDEOTSum[1]), "ratioTDEOTMin")
    r$dfSave(as.numeric(ratioTDEOTSum[2]), "ratioTDEOTlower")
    r$dfSave(as.numeric(ratioTDEOTSum[3]), "ratioTDEOTMedian")
    r$dfSave(as.numeric(ratioTDEOTSum[4]), "ratioTDEOTMean")
    r$dfSave(as.numeric(ratioTDEOTSum[5]), "ratioTDEOTUpper")
    r$dfSave(as.numeric(ratioTDEOTSum[6]), "ratioTDEOTMax")

    cat(
      "The summary table of the final ratios of the TDEOT across all simulations\n",
      capture.output(ratioTDEOTSum)[1],
      "\n",
      capture.output(ratioTDEOTSum)[2],
      "\n"
    )

    TDDTSum <- object@tddt_summary

    r$dfSave(as.numeric(TDDTSum[1]), "TDDTMin")
    r$dfSave(as.numeric(TDDTSum[2]), "TDDTlower")
    r$dfSave(as.numeric(TDDTSum[3]), "TDDTMedian")
    r$dfSave(as.numeric(TDDTSum[4]), "TDDTMean")
    r$dfSave(as.numeric(TDDTSum[5]), "TDDTUpper")
    r$dfSave(as.numeric(TDDTSum[6]), "TDDTMax")

    cat(
      "The summary table of the final TDDT across all simulations\n",
      capture.output(TDDTSum)[1],
      "\n",
      capture.output(TDDTSum)[2],
      "\n"
    )

    final_dose_rec_sum <- object@final_dose_rec_summary

    r$dfSave(as.numeric(final_dose_rec_sum[1]), "FinalDoseRecMin")
    r$dfSave(as.numeric(final_dose_rec_sum[2]), "FinalDoseReclower")
    r$dfSave(as.numeric(final_dose_rec_sum[3]), "FinalDoseRecMedian")
    r$dfSave(as.numeric(final_dose_rec_sum[4]), "FinalDoseRecMean")
    r$dfSave(as.numeric(final_dose_rec_sum[5]), "FinalDoseRecUpper")
    r$dfSave(as.numeric(final_dose_rec_sum[6]), "FinalDoseRecMax")

    cat(
      "The summary table of dose levels, the optimal dose\n to recommend for subsequent study across all simulations\n",
      capture.output(final_dose_rec_sum)[1],
      "\n",
      capture.output(final_dose_rec_sum)[2],
      "\n"
    )

    final_ratio_sum <- object@final_ratio_summary

    r$dfSave(as.numeric(final_ratio_sum[1]), "FinalratioMin")
    r$dfSave(as.numeric(final_ratio_sum[2]), "Finalratiolower")
    r$dfSave(as.numeric(final_ratio_sum[3]), "FinalratioMedian")
    r$dfSave(as.numeric(final_ratio_sum[4]), "FinalratioMean")
    r$dfSave(as.numeric(final_ratio_sum[5]), "FinalratioUpper")
    r$dfSave(as.numeric(final_ratio_sum[6]), "FinalratioMax")

    cat(
      "The summary table of the final ratios of the optimal dose for stopping across
                  all simulations\n",
      capture.output(final_ratio_sum)[1],
      "\n",
      capture.output(final_ratio_sum)[2],
      "\n\n"
    )

    # Report individual stopping rules with non-NA labels.
    stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

    if (length(stop_pct_to_print) > 0) {
      cat(
        "Stop reason triggered:\n",
        paste(names(stop_pct_to_print), ": ", stop_pct_to_print, "%\n")
      )
    }

    # Finally assign names to the df and return it invisibly.
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)

# plot-PseudoSimulationsSummary ----

#' Plot `PseudoSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Graphical display of the simulation summary.
#'
#' This plot method can be applied to [`PseudoSimulationsSummary`] objects in
#' order to summarize them graphically. This can be used when only DLE responses
#' are involved in the simulations. This also applied to results with or without
#' samples generated during the simulations.
#'
#' @param x (`PseudoSimulationsSummary`)\cr the object we want to plot from.
#' @param y (`missing`)\cr missing object, not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot2` object if a single plot is asked for, otherwise a
#'   `gtable` object.
#'
#' @aliases plot-PseudoSimulationsSummary-missing
#' @example examples/Simulations-method-plotSUMsingle.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "PseudoSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLE",
      "nAboveTargetEndOfTrial",
      "meanFit"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Distribution of overall sample size.
    if ("nObs" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_barplot_percentages(
          x = x@n_obs,
          description = "Number of patients in total"
        )
    }

    # Distribution of final MTD estimate.
    if ("doseSelected" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_barplot_percentages(
          x = x@dose_selected,
          description = "MTD estimate"
        )
    }

    # Distribution of proportion of DLTs.
    if ("propDLE" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_barplot_percentages(
          x = x@prop_dle * 100,
          description = "Proportion of DLE [%]",
          xaxisround = 1
        )
    }

    # Distribution of number of patients treated at too much tox.
    if ("nAboveTargetEndOfTrial" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_barplot_percentages(
          x = x@n_above_target_end_of_trial,
          description = "Number of patients above target"
        )
    }

    # First combine these small plots.
    if (length(plot_list)) {
      ret <-
        # If there is only one plot.
        if (identical(length(plot_list), 1L)) {
          # Just use that.
          plot_list[[1L]]
        } else {
          # Multiple plots in this case.
          do.call(
            gridExtra::arrangeGrob,
            plot_list
          )
        }
    }

    # The meanFit plot.
    if ("meanFit" %in% type) {
      # Find if DLE samples are generated in the simulations by checking if
      # the lower limits of the 95% credibility interval are calculated.
      if (!is.null(x@mean_fit$lower)) {
        # Which types of lines do we have?
        linetype <- c(
          "True toxicity",
          "Average estimated toxicity",
          "95% interval for estimated toxicity"
        )

        # Create the data frame, with true tox, average estimated tox, and 95%
        # (lower, upper) estimated tox (in percentage) stacked below each other.
        dat <- data.frame(
          dose = rep(x@dose_grid, 4L),
          group = rep(1:4, each = length(x@dose_grid)),
          linetype = factor(
            rep(linetype[c(1, 2, 3, 3)], each = length(x@dose_grid)),
            levels = linetype
          ),
          lines = unlist(x@mean_fit) * 100
        )

        # Linetypes for the plot.
        lt <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 1,
          "95% interval for estimated toxicity" = 2
        )

        # Colour for the plot.
        col <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 2,
          "95% interval for estimated toxicity" = 2
        )

        # Now create and save the plot.
        this_plot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        this_plot <- this_plot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Probability of DLE [%]")
      } else {
        # Which types of lines do we have?
        linetype <- c(
          "True toxicity",
          "Average estimated toxicity"
        )

        # Create the data frame, with true tox, average estimated tox
        # (in percentage) stacked below each other.
        dat <- data.frame(
          dose = rep(x@dose_grid, 2L),
          group = rep(1:2, each = length(x@dose_grid)),
          linetype = factor(
            rep(linetype[c(1, 2)], each = length(x@dose_grid)),
            levels = linetype
          ),
          lines = unlist(x@mean_fit) * 100
        )

        # Linetypes for the plot.
        lt <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 1
        )

        # Colour for the plot.
        col <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 2
        )

        # Now create and save the plot.
        this_plot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        this_plot <- this_plot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Probability of DLE [%]")
      }

      # Then add this plot at the bottom.
      ret <- if (exists("ret")) {
        gridExtra::arrangeGrob(ret, this_plot)
      } else {
        this_plot
      }
    }
    ret
  }
)

# plot-PseudoDualSimulations ----

#' Plot `PseudoDualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the simulations with plots.
#'
#' This plot method can be applied to [`PseudoDualSimulations`] objects in
#' order to summarize them graphically. Possible `type`s of plots at the moment
#' are:
#' \describe{
#'   \item{trajectory}{Summary of the trajectory of the simulated trials}
#'   \item{dosesTried}{Average proportions of the doses tested in patients}
#'   \item{sigma2}{The variance of the efficacy responses}
#' }
#' You can specify one or both of these in the `type` argument.
#'
#' @param x (`PseudoDualSimulations`)\cr the object we want to plot from.
#' @param y (`missing`)\cr missing object, not used.
#' @param type (`character`)\cr the type of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot2` object if a single plot is asked for, otherwise a
#'   `gtable` object.
#'
#' @aliases plot-PseudoDualSimulations-missing
#' @example examples/Simulations-method-plotSIMDual.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "PseudoDualSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "trajectory",
      "dosesTried",
      "sigma2"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Subtract the specific plot types for dual-endpoint simulation results.
    type_reduced <- setdiff(
      type,
      "sigma2"
    )

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      gen_plot <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Now to the specific dual-endpoint plots:
    # Efficacy variance estimates boxplot.
    if ("sigma2" %in% type) {
      # Save the plot.
      plot_list[[plot_index <- plot_index + 1L]] <-
        ggplot(data = data.frame(y = x@sigma2_est), aes(x = factor(0), y = y)) +
        geom_boxplot() +
        coord_flip() +
        scale_x_discrete(breaks = NULL) +
        xlab("") +
        ylab("Efficacy variance estimates")
    }

    # Then finally plot everything.
    if (identical(length(plot_list), 0L)) {
      return(gen_plot)
    } else if (identical(length(plot_list), 1L)) {
      ret <- plot_list[[1L]]
    } else {
      ret <- do.call(
        gridExtra::arrangeGrob,
        plot_list
      )
    }

    if (more_from_general) {
      ret <- gridExtra::arrangeGrob(gen_plot, ret, heights = c(2 / 3, 1 / 3))
    }

    ret
  }
)

# plot-PseudoDualFlexiSimulations ----

#' Plot `PseudoDualFlexiSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the simulations with plots.
#'
#' This plot method can be applied to [`PseudoDualFlexiSimulations`] objects in
#' order to summarize them graphically. Possible `type`s of plots at the moment
#' are:
#'
#' \describe{
#'   \item{trajectory}{Summary of the trajectory of the simulated trials}
#'   \item{dosesTried}{Average proportions of the doses tested in patients}
#'   \item{sigma2}{The variance of the efficacy responses}
#'   \item{sigma2betaW}{The variance of the random walk model}
#' }
#'
#' You can specify one or both of these in the `type` argument.
#'
#' @param x (`PseudoDualFlexiSimulations`)\cr the object we want to plot from.
#' @param y (`missing`)\cr missing object, not used.
#' @param type (`character`)\cr the type of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot2` object if a single plot is asked for, otherwise a
#'   `gtable` object.
#'
#' @aliases plot-PseudoDualFlexiSimulations-missing
#' @example examples/Simulations-method-plotSIMDualFlexi.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "PseudoDualFlexiSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "trajectory",
      "dosesTried",
      "sigma2",
      "sigma2betaW"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Subtract the specific plot types for dual-endpoint simulation results.
    type_reduced <- setdiff(type, "sigma2betaW")

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      gen_plot <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Now to the specific dual-endpoint plots:
    # Random walk model variance estimates boxplot.
    if ("sigma2betaW" %in% type) {
      # Save the plot.
      plot_list[[plot_index <- plot_index + 1L]] <-
        ggplot(
          data = data.frame(y = x@sigma2_beta_w_est),
          aes(x = factor(0), y = y)
        ) +
        geom_boxplot() +
        coord_flip() +
        scale_x_discrete(breaks = NULL) +
        xlab("") +
        ylab("Random walk model variance estimates")
    }

    # Then finally plot everything.
    if (identical(length(plot_list), 0L)) {
      return(gen_plot)
    } else if (identical(length(plot_list), 1L)) {
      ret <- plot_list[[1L]]
    } else {
      ret <- do.call(
        gridExtra::arrangeGrob,
        plot_list
      )
    }

    if (more_from_general) {
      ret <- gridExtra::arrangeGrob(gen_plot, ret, heights = c(2 / 3, 1 / 3))
    }

    ret
  }
)

# summary-PseudoDualSimulations ----

#' Summarize `PseudoDualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summary for Pseudo Dual responses simulations, relative to a given pseudo
#' DLE and efficacy model (except the EffFlexi class model).
#'
#' @param object (`PseudoDualSimulations`)\cr the object we want to summarize.
#' @param trueDLE (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the true probability (vector) of DLE.
#' @param trueEff (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the mean efficacy value(s) (vector).
#' @param targetEndOfTrial (`number`)\cr the target probability of DLE that are
#'   used at the end of a trial. Default at 0.3.
#' @param targetDuringTrial (`number`)\cr the target probability of DLE that
#'   are used during the trial. Default at 0.35.
#' @param ... additional arguments can be supplied here for `trueDLE` and
#'   `trueEff`.
#'
#' @return An object of class [`PseudoDualSimulationsSummary`].
#'
#' @aliases summary-PseudoDualSimulations
#' @example examples/Simulations-method-summarySIMDual.R
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "PseudoDualSimulations"),
  def = function(
    object,
    trueDLE,
    trueEff,
    targetEndOfTrial = 0.3,
    targetDuringTrial = 0.35,
    ...
  ) {
    # Validate arguments.
    assert_function(trueDLE)
    assert_number(targetEndOfTrial, lower = 0, upper = 1)
    assert_number(targetDuringTrial, lower = 0, upper = 1)

    # Call the parent method.
    start <- callNextMethod(
      object = object,
      truth = trueDLE,
      targetEndOfTrial = targetEndOfTrial,
      targetDuringTrial = targetDuringTrial,
      ...
    )
    dose_grid <- object@data[[1]]@doseGrid

    # Dose level most often selected as MTD (TDtargetEnd of Trial).
    x_most_selected <-
      match_within_tolerance(start@dose_most_selected, table = dose_grid)

    # Check if true Eff is a function (check if special case applies).
    is_true_eff_fx <- is.function(trueEff)

    td_target_end_of_trial <- start@target_dose_end_of_trial

    if (is_true_eff_fx) {
      neg_true_gain_fn <- function(dose) {
        -(trueEff(dose)) / (1 + (trueDLE(dose) / (1 - trueDLE(dose))))
      }
      gstar <- optim(exp(1), neg_true_gain_fn, method = "BFGS")$par
      max_gain_value <- -(optim(
        exp(1),
        neg_true_gain_fn,
        method = "BFGS"
      )$value)
      gstar_at_dose_grid <- dose_grid[max(which(gstar - dose_grid >= 0))]
    } else {
      true_gain <- (trueEff) /
        (1 + (trueDLE(dose_grid) / (1 - trueDLE(dose_grid))))
      max_gain_value <- max(true_gain)
      gstar <- dose_grid[which.max(true_gain)]
      gstar_at_dose_grid <- gstar
    }

    # A summary for all final Gstar obtained.
    gstar_summary <- summary(object@final_gstar_estimates)
    ratio_gstar_summary <- summary(object@final_gstar_ratios)

    final_dose_rec_summary <- summary(object@final_optimal_dose)
    final_ratio_summary <- summary(object@final_ratios)

    # Find names in the fit efficacy list (check if with or without samples).
    fit_names <- sapply(object@fit_eff, names)
    if ("ExpEff" %in% fit_names) {
      # Fitted efficacy level at dose most often selected.
      eff_fit_at_dose_most_selected <- sapply(
        object@fit_eff,
        function(f) {
          f$ExpEff[x_most_selected]
        }
      )
      mean_eff_fit_matrix <- sapply(
        object@fit_eff,
        "[[",
        "ExpEff"
      )

      mean_eff_fit <- list(
        truth = trueEff(dose_grid),
        average = rowMeans(mean_eff_fit_matrix)
      )
    } else {
      # Fitted efficacy level at dose most often selected.
      eff_fit_at_dose_most_selected <-
        sapply(
          object@fit_eff,
          function(f) {
            f$middle[x_most_selected]
          }
        )

      # Mean fitted curve (average, lower and upper quantiles) at each dose
      # level (this is required for plotting).
      mean_eff_fit_matrix <- sapply(
        object@fit_eff,
        "[[",
        "middle"
      )

      # Check if special case applies.
      if (is_true_eff_fx) {
        truth_eff <- trueEff(dose_grid)
      } else {
        truth_eff <- trueEff
      }

      mean_eff_fit <- list(
        truth = truth_eff,
        average = rowMeans(mean_eff_fit_matrix),
        lower = apply(
          mean_eff_fit_matrix,
          1L,
          quantile,
          0.025
        ),
        upper = apply(
          mean_eff_fit_matrix,
          1L,
          quantile,
          0.975
        )
      )
    }

    # Give back an object of class PseudoDualSimulationsSummary.
    .PseudoDualSimulationsSummary(
      start,
      target_gstar = gstar,
      target_gstar_at_dose_grid = gstar_at_dose_grid,
      gstar_summary = gstar_summary,
      ratio_gstar_summary = ratio_gstar_summary,
      final_dose_rec_summary = final_dose_rec_summary,
      final_ratio_summary = final_ratio_summary,
      eff_fit_at_dose_most_selected = eff_fit_at_dose_most_selected,
      mean_eff_fit = mean_eff_fit,
      stop_report = object@stop_report
    )
  }
)

# summary-PseudoDualFlexiSimulations ----

#' Summarize `PseudoDualFlexiSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summary for `PseudoDualFlexiSimulations` given a pseudo DLE model and
#' the flexible efficacy model.
#'
#' @param object (`PseudoDualFlexiSimulations`)\cr the object we want to
#'   summarize.
#' @param trueDLE (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the true probability of DLE (vector).
#' @param trueEff (`numeric`)\cr a vector which takes as input the true mean
#'   efficacy values at all dose levels (in order).
#' @param targetEndOfTrial (`number`)\cr the target probability of DLE that are
#'   used at the end of a trial. Default at 0.3.
#' @param targetDuringTrial (`number`)\cr the target probability of DLE that
#'   are used during the trial. Default at 0.35.
#' @param ... additional arguments can be supplied here for `trueDLE` and
#'   `trueEff`.
#'
#' @return An object of class [`PseudoDualSimulationsSummary`].
#'
#' @aliases summary-PseudoDualFlexiSimulations
#' @example examples/Simulations-method-summarySIMDualFlexi.R
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "PseudoDualFlexiSimulations"),
  def = function(
    object,
    trueDLE,
    trueEff,
    targetEndOfTrial = 0.3,
    targetDuringTrial = 0.35,
    ...
  ) {
    # Validate arguments.
    assert_function(trueDLE)
    assert_multi_class(trueEff, classes = c("numeric", "function"))
    assert_number(targetEndOfTrial, lower = 0, upper = 1)
    assert_number(targetDuringTrial, lower = 0, upper = 1)

    # Call the parent method.
    start <- callNextMethod(
      object = object,
      trueDLE = trueDLE,
      trueEff = trueEff,
      targetEndOfTrial = targetEndOfTrial,
      targetDuringTrial = targetDuringTrial,
      ...
    )

    # Give back an object of class PseudoDualSimulationsSummary.
    .PseudoDualSimulationsSummary(start)
  }
)

# show-PseudoDualSimulationsSummary ----

#' Show the Summary of `PseudoDualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of pseudo dual simulation results.
#'
#' @param object (`PseudoDualSimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'  appropriate column names.
#'
#' @aliases show-PseudoDualSimulationsSummary
#' @example examples/Simulations-method-showSIMDual.R
#' @export
#'
setMethod(
  f = "show",
  signature = signature(object = "PseudoDualSimulationsSummary"),
  def = function(object) {
    # Call the parent method.
    df <- callNextMethod(object)
    df_names <- names(df)

    # Start report object.
    r <- Report$new(
      object = object,
      df = df,
      dfNames = df_names
    )

    # Add three reporting lines.
    cat(
      "Target Gstar, the dose which gives the maximum gain value was",
      r$dfSave(
        object@target_gstar,
        "targetGstar"
      ),
      "\n"
    )
    cat(
      "Target Gstar at dose Grid was",
      r$dfSave(
        object@target_gstar_at_dose_grid,
        "targetGstarAtDoseGrid"
      ),
      "\n"
    )

    GstarSum <- object@gstar_summary

    r$dfSave(as.numeric(GstarSum[1]), "GstarMin")
    r$dfSave(as.numeric(GstarSum[2]), "Gstarlower")
    r$dfSave(as.numeric(GstarSum[3]), "GstarMedian")
    r$dfSave(as.numeric(GstarSum[4]), "GstarMean")
    r$dfSave(as.numeric(GstarSum[5]), "GstarUpper")
    r$dfSave(as.numeric(GstarSum[6]), "GstarMax")

    cat(
      "The summary table of the final Gstar across all simulations\n",
      capture.output(GstarSum)[1],
      "\n",
      capture.output(GstarSum)[2],
      "\n"
    )

    ratio_gstar_sum <- object@ratio_gstar_summary

    r$dfSave(as.numeric(ratio_gstar_sum[1]), "ratioGstarMin")
    r$dfSave(as.numeric(ratio_gstar_sum[2]), "ratioGstarlower")
    r$dfSave(as.numeric(ratio_gstar_sum[3]), "ratioGstarMedian")
    r$dfSave(as.numeric(ratio_gstar_sum[4]), "ratioGstarMean")
    r$dfSave(as.numeric(ratio_gstar_sum[5]), "ratioGstarUpper")
    r$dfSave(as.numeric(ratio_gstar_sum[6]), "ratioGstarMax")

    cat(
      "The summary table of the final ratios of the Gstar across all simulations\n",
      capture.output(ratio_gstar_sum)[1],
      "\n",
      capture.output(ratio_gstar_sum)[2],
      "\n"
    )

    final_dose_rec_sum <- object@final_dose_rec_summary

    r$dfSave(as.numeric(final_dose_rec_sum[1]), "FinalDoseRecMin")
    r$dfSave(as.numeric(final_dose_rec_sum[2]), "FinalDoseReclower")
    r$dfSave(as.numeric(final_dose_rec_sum[3]), "FinalDoseRecMedian")
    r$dfSave(as.numeric(final_dose_rec_sum[4]), "FinalDoseRecMean")
    r$dfSave(as.numeric(final_dose_rec_sum[5]), "FinalDoseRecUpper")
    r$dfSave(as.numeric(final_dose_rec_sum[6]), "FinalDoseRecMax")

    cat(
      "The summary table of dose levels, the optimal dose\n to recommend for subsequent study across all simulations\n",
      capture.output(final_dose_rec_sum)[1],
      "\n",
      capture.output(final_dose_rec_sum)[2],
      "\n"
    )

    final_ratio_sum <- object@final_ratio_summary

    r$dfSave(as.numeric(final_ratio_sum[1]), "FinalratioMin")
    r$dfSave(as.numeric(final_ratio_sum[2]), "Finalratiolower")
    r$dfSave(as.numeric(final_ratio_sum[3]), "FinalratioMedian")
    r$dfSave(as.numeric(final_ratio_sum[4]), "FinalratioMean")
    r$dfSave(as.numeric(final_ratio_sum[5]), "FinalratioUpper")
    r$dfSave(as.numeric(final_ratio_sum[6]), "FinalratioMax")

    cat(
      "The summary table of the final ratios of the optimal dose for stopping across
        all simulations\n",
      capture.output(final_ratio_sum)[1],
      "\n",
      capture.output(final_ratio_sum)[2],
      "\n"
    )

    r$report(
      "eff_fit_at_dose_most_selected",
      "Fitted expected efficacy level at dose most often selected",
      percent = FALSE,
      digits = 1
    )

    # Report individual stopping rules with non-NA labels.
    stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

    if (length(stop_pct_to_print) > 0) {
      cat(
        "Stop reason triggered:\n",
        paste(names(stop_pct_to_print), ": ", stop_pct_to_print, "%\n")
      )
    }

    # And return the updated information.
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)

# plot-PseudoDualSimulationsSummary ----

#' Plot `PseudoDualSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Plot the summary of `PseudoDualSimulations`.
#'
#' This plot method can be applied to [`PseudoDualSimulationsSummary`] objects
#' in order to summarize them graphically. Possible `type` of plots at the
#' moment are those listed in [`plot,PseudoSimulationsSummary,missing-method`]
#' plus:
#'
#' \describe{
#'   \item{meanEffFit}{Plot showing the fitted dose-efficacy curve. If no
#'     samples are involved, only the average fitted dose-efficacy curve across
#'     the trials will be plotted. If samples (DLE and efficacy) are involved,
#'     the average fitted dose-efficacy curve across the trials, together with
#'     the 95% credibility interval; and comparison with the assumed truth (as
#'     specified by the `trueEff` argument to
#'     [`summary,PseudoDualSimulations-method`])}
#' }
#'
#' You can specify any subset of these in the `type` argument.
#'
#' @param x (`PseudoDualSimulationsSummary`)\cr the object we want to plot
#'   from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot2` object if a single plot is asked for, otherwise a
#'   `gtable` object.
#'
#' @aliases plot-PseudoDualSimulationsSummary-missing
#' @example examples/Simulations-method-plotSUMDual.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "PseudoDualSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLE",
      "nAboveTargetEndOfTrial",
      "meanFit",
      "meanEffFit"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Subtract the specific plot types for dual-endpoint designs.
    type_reduced <- setdiff(
      type,
      "meanEffFit"
    )

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      ret <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Is the meanEffFit plot requested?
    if ("meanEffFit" %in% type) {
      # Find if Eff samples are generated in the simulations by checking if
      # the lower limits of the 95% credibility interval are calculated.
      if (!is.null(x@mean_eff_fit$lower)) {
        # Which types of lines do we have?
        linetype <- c(
          "True Expected Efficacy",
          "Average estimated expected efficacy",
          "95% interval for estimated expected efficacy"
        )

        # Create the data frame, with true expected efficacy, average
        # estimated expected efficacy, and 95% (lower, upper) estimated
        # expected efficacy stacked below each other.
        dat <- data.frame(
          dose = rep(x@dose_grid, 4L),
          group = rep(1:4, each = length(x@dose_grid)),
          linetype = factor(
            rep(linetype[c(1, 2, 3, 3)], each = length(x@dose_grid)),
            levels = linetype
          ),
          lines = unlist(x@mean_eff_fit)
        )

        # Linetypes for the plot.
        lt <- c(
          "True Expected Efficacy" = 1,
          "Average estimated expected efficacy" = 1,
          "95% interval for estimated expected efficacy" = 2
        )

        # Colour for the plot.
        col <- c(
          "True Expected Efficacy" = 1,
          "Average estimated expected efficacy" = 4,
          "95% interval for estimated expected efficacy" = 4
        )

        # Now create and save the plot.
        this_plot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        this_plot <- this_plot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Expected Efficacy level")
      } else {
        # Which types of lines do we have?
        linetype <- c(
          "True Expected Efficacy",
          "Average estimated expected efficacy"
        )

        # Create the data frame, with true expected efficacy and average
        # estimated expected efficacy.
        dat <- data.frame(
          dose = rep(x@dose_grid, 2L),
          group = rep(1:2, each = length(x@dose_grid)),
          linetype = factor(
            rep(linetype[c(1, 2)], each = length(x@dose_grid)),
            levels = linetype
          ),
          lines = unlist(x@mean_eff_fit)
        )

        # Linetypes for the plot.
        lt <- c(
          "True Expected Efficacy" = 1,
          "Average estimated expected efficacy" = 1
        )

        # Colour for the plot.
        col <- c(
          "True Expected Efficacy" = 1,
          "Average estimated expected efficacy" = 4
        )

        # Now create and save the plot.
        this_plot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        this_plot <- this_plot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Expected Efficacy level")
      }

      # Add this plot to the bottom.
      ret <-
        if (more_from_general) {
          gridExtra::arrangeGrob(ret, this_plot, heights = c(2 / 3, 1 / 3))
        } else {
          this_plot
        }
    }

    # Then finally plot everything.
    ret
  }
)

#' @include McmcOptions-class.R
#' @include Model-methods.R
#' @include fromQuantiles.R
NULL

# size ----

## Samples ----

#' @describeIn size get the number of MCMC samples from `Samples` object.
#' @aliases size-Samples
#'
#' @export
#' @example examples/Samples-methods-size.R
#'
setMethod(
  f = "size",
  signature = signature(object = "Samples"),
  definition = function(object, ...) {
    size(object@options)
  }
)

# names ----

## Samples ----

#' The Names of the Sampled Parameters
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that returns names of the parameters that are sampled.
#'
#' @param x (`Samples`)\cr object with samples.
#'
#' @aliases names-Samples
#' @export
#' @example examples/Samples-methods-names.R
#'
setMethod(
  f = "names",
  signature = signature(x = "Samples"),
  definition = function(x) {
    names(x@data)
  }
)

## --------------------------------------------------
## Extract certain parameter from "Samples" object to produce
## plots with "ggmcmc" package
## --------------------------------------------------

# The next line is required to suppress the message "Creating a generic function
# for ‘get’ from package ‘base’ in package ‘crmPack’" on package load.
# See https://github.com/openpharma/crmPack/issues/723
setGeneric("get")

#' Get specific parameter samples and produce a data.frame
#'
#' Here you have to specify with \code{pos} which
#' parameter you would like to extract from the \code{\linkS4class{Samples}}
#' object
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param pos the name of the parameter
#' @param envir for vectorial parameters, you can give the indices of the
#' elements you would like to extract. If \code{NULL}, the whole vector samples
#' will be returned
#' @param mode not used
#' @param inherits not used
#'
#' @return the data frame suitable for use with \code{\link[ggmcmc]{ggmcmc}}
#'
#' @example examples/Sample-methods-get.R
#' @export
#' @keywords methods
setMethod(
  "get",
  signature = signature(
    x = "Samples",
    pos = "character",
    envir = "ANY",
    mode = "ANY",
    inherits = "ANY"
  ),
  def = function(x, pos, envir = NULL, mode = NULL, inherits = NULL) {
    ## check the parameter name
    assert_scalar(pos)
    assert_choice(pos, names(x))

    ## get the samples for this parameter
    d <- x@data[[pos]]
    ## this can be either a vector or a matrix

    ## how many parameters do we have?
    nPars <- NCOL(d)

    ## what are the names of all parameter
    ## elements?
    elements <-
      if (nPars == 1L) {
        pos
      } else {
        paste(pos, "[", seq_len(nPars), "]", sep = "")
      }

    ## in case we have a vector parameter
    if (nPars > 1L) {
      ## what are the indices to be returned?
      indices <-
        if (is.null(envir)) {
          seq_along(elements)
        } else {
          assert_integer(envir)
          assert_subset(envir, seq_along(elements))
        }

      ## subset the data matrix and par names appropriately
      d <- d[, indices, drop = FALSE]
      elements <- elements[indices]

      ## and also reduce the number of parameters
      nPars <- length(indices)
    }

    ## now we can build
    ret <- data.frame(
      Iteration = seq_len(NROW(d)),
      Chain = 1L,
      Parameter = factor(rep(elements, each = NROW(d)), levels = elements),
      value = as.numeric(d)
    )

    ## add the attributes
    structure(
      ret,
      nChains = 1L,
      nParameters = nPars,
      nIterations = x@options@iterations,
      nBurnin = x@options@burnin,
      nThin = x@options@step,
      description = elements,
      parallel = FALSE
    )
  }
)


## --------------------------------------------------
## Get fitted curves from Samples
## --------------------------------------------------

#' Fit method for the Samples class
#'
#' Note this new generic function is necessary because the \code{\link{fitted}}
#' function only allows the first argument \code{object} to appear in the
#' signature. But we need also other arguments in the signature.
#'
#' @param object the \code{\linkS4class{Samples}} object
#' @param model the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param \dots passed down to the [prob()] method.
#' @return the data frame with required information (see method details)
#'
#' @export
#' @keywords methods
setGeneric(
  "fit",
  def = function(object, model, data, ...) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("fit")
  },
  valueClass = "data.frame"
)


## --------------------------------------------------
## Get fitted dose-tox curve from Samples
## --------------------------------------------------

#' @param points at which dose levels is the fit requested? default is the dose
#' grid
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#'
#' @describeIn fit This method returns a data frame with dose, middle, lower
#' and upper quantiles for the dose-toxicity curve
#' @example examples/Sample-methods-fit.R
#'
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the dose-tox
    ## curve at the dose grid points.
    probSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    ## evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      probSamples[, i] <- prob(
        dose = points[i],
        model,
        object,
        ...
      )
    }

    ## extract middle curve
    middleCurve <- apply(probSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(probSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)

## --------------------------------------------------
## Get fitted dose-tox and dose-biomarker curves from Samples
## --------------------------------------------------

#' @describeIn fit This method returns a data frame with dose, and middle,
#' lower and upper quantiles, for both the dose-tox and dose-biomarker (suffix
#' "Biomarker") curves, for all grid points (Note that currently only the grid
#' points can be used, because the DualEndpointRW models only allow that)
#'
#' @example examples/Sample-methods-fit-DualEndpoint.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "DualEndpoint",
    data = "DataDual"
  ),
  def = function(
    object,
    model,
    data,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)

    ## first obtain the dose-tox curve results from the parent method
    start <- callNextMethod(
      object = object,
      model = model,
      data = data,
      points = data@doseGrid,
      quantiles = quantiles,
      middle = middle,
      ...
    )

    ## now obtain the dose-biomarker results

    ## get the biomarker level samples
    ## at the dose grid points.
    biomLevelSamples <- biomarker(
      xLevel = seq_len(data@nGrid),
      model,
      samples = object
    )

    ## extract middle curve
    middleCurve <- apply(biomLevelSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(biomLevelSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    biomResults <- data.frame(
      middleBiomarker = middleCurve,
      lowerBiomarker = quantCurve[1, ],
      upperBiomarker = quantCurve[2, ]
    )

    ## return both, pasted together
    cbind(start, biomResults)
  }
)

## --------------------------------------------------
## Approximate posterior with (log) normal distribution
## --------------------------------------------------

#' Approximate posterior with (log) normal distribution
#'
#' To reproduce the resultant approximate model in the future exactly, include
#' \code{seed = xxxx} in the call to `approximate`.
#'
#' @param object the \code{\linkS4class{Samples}} object
#' @param model the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param \dots additional arguments (see methods)
#' @return a `list` containing the approximation model and, if requested, a
#' `ggplot2` object containing a graphical representation of the fitted model
#'
#' @export
#' @keywords methods
setGeneric(
  "approximate",
  def = function(object, model, data, ...) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("approximate")
  },
  valueClass = "list"
)


##' @param points optional parameter, which gives the dose values at which
##' the approximation should rely on (default: 5 values equally spaced from
##' minimum to maximum of the dose grid)
##' @param refDose the reference dose to be used (default: median of
##' \code{points})
##' @param logNormal use the log-normal prior? (not default) otherwise, the
##' normal prior for the logistic regression coefficients is used
##' @param verbose be verbose (progress statements)? (default)
##' @param create_plot add a `ggplot2` object to the return value (default)
##'
##' @describeIn approximate Here the \dots argument can transport additional arguments for
##' \code{\link{Quantiles2LogisticNormal}}, e.g. in order to control the
##' approximation quality, etc.
##'
##' @example examples/Sample-methods-approximate.R
setMethod(
  "approximate",
  signature = signature(object = "Samples"),
  def = function(
    object,
    model,
    data,
    points = seq(
      from = min(data@doseGrid),
      to = max(data@doseGrid),
      length = 5L
    ),
    refDose = median(points),
    logNormal = FALSE,
    verbose = TRUE,
    create_plot = TRUE,
    ...
  ) {
    # Validation
    assert_logical(logNormal)
    assert_logical(verbose)
    assert_logical(create_plot)
    assert_numeric(points)
    assert_numeric(refDose)
    ## get the required quantiles at these dose levels:
    quants <- fit(
      object,
      model,
      data,
      points = points,
      quantiles = c(0.025, 0.975),
      middle = median
    )

    ## get better starting values if it is already a logistic normal
    ## model
    if (is(model, "LogisticNormal") && (!logNormal)) {
      means <- sapply(
        object@data,
        mean
      )
      cov <- cov(as.data.frame(object@data))

      parstart <- c(
        means[1],
        means[2],
        sqrt(cov[1, 1]),
        sqrt(cov[2, 2]),
        cov2cor(cov)[1, 2]
      )
    } else if (is(model, "LogisticLogNormal") && logNormal) {
      datTrafo <- with(
        object@data,
        cbind(
          alpha0,
          log(alpha1)
        )
      )

      means <- colMeans(datTrafo)
      cov <- cov(datTrafo)

      parstart <- c(
        means[1],
        means[2],
        sqrt(cov[1, 1]),
        sqrt(cov[2, 2]),
        cov2cor(cov)[1, 2]
      )
    } else {
      parstart <- NULL
    }

    ## run the approx function
    quantRes <- Quantiles2LogisticNormal(
      dosegrid = quants$dose,
      refDose = refDose,
      lower = quants$lower,
      upper = quants$upper,
      median = quants$middle,
      verbose = verbose,
      parstart = parstart,
      logNormal = logNormal,
      ...
    )
    rv <- list()
    rv$model <- quantRes$model
    if (create_plot) {
      rv$plot <- tibble::as_tibble(quantRes$required) %>%
        tibble::add_column(Type = "original") %>%
        tibble::add_column(x = points) %>%
        dplyr::bind_rows(
          tibble::as_tibble(quantRes$quantiles) %>%
            tibble::add_column(Type = "approximation") %>%
            tibble::add_column(x = points)
        ) %>%
        tidyr::pivot_longer(
          c(lower, median, upper),
          names_to = "Line",
          values_to = "y"
        ) %>%
        ggplot(
          aes(
            x = x,
            y = y,
            colour = Type,
            group = interaction(Type, .data$Line),
            linetype = (.data$Line == "median")
          )
        ) +
        geom_line() +
        scale_colour_manual(
          name = " ",
          values = c("red", "blue")
        ) +
        scale_linetype_manual(
          name = " ",
          values = c("dotted", "solid"),
          labels = c("95% CI", "Median"),
          guide = guide_legend(reverse = TRUE)
        ) +
        labs(
          x = "Dose",
          y = "p(Tox)"
        ) +
        theme_light()
    }
    rv
  }
)

## --------------------------------------------------
## Plot dose-tox fit from a model
## --------------------------------------------------

#' Plotting dose-toxicity model fits
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-toxicity model fit
#'
#' @example examples/Sample-methods-plot.R
#' @export
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "GeneralModel"
  ),
  def = function(
    x,
    y,
    data,
    ...,
    xlab = "Dose level",
    ylab = "Probability of DLT [%]",
    showLegend = TRUE
  ) {
    ## check args
    assert_logical(showLegend)

    ## get the fit
    plotData <- fit(
      x,
      model = y,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean,
      ...
    )

    ## make the plot
    gdata <-
      with(
        plotData,
        data.frame(
          x = rep(dose, 3),
          y = c(middle, lower, upper) * 100,
          group = rep(c("mean", "lower", "upper"), each = nrow(plotData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )

    ret <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type,
        ),
        colour = I("red"),
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      labs(
        x = xlab,
        y = ylab,
      )

    ret +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
  }
)


## --------------------------------------------------
## Special method for dual endpoint model
## --------------------------------------------------

#' Plotting dose-toxicity and dose-biomarker model fits
#'
#' When we have the dual endpoint model,
#' also the dose-biomarker fit is shown in the plot
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{DualEndpoint}} object
#' @param data the \code{\linkS4class{DataDual}} object
#' @param extrapolate should the biomarker fit be extrapolated to the whole
#' dose grid? (default)
#' @param showLegend should the legend be shown? (not default)
#' @param \dots additional arguments for the parent method
#' \code{\link{plot,Samples,GeneralModel-method}}
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object with the dose-toxicity and dose-biomarker model fits
#'
#' @example examples/Sample-methods-plot-DualEndpoint.R
#' @export
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "DualEndpoint"
  ),
  def = function(x, y, data, extrapolate = TRUE, showLegend = FALSE, ...) {
    assert_logical(extrapolate)

    ## call the superclass method, to get the toxicity plot
    plot1 <- callNextMethod(x, y, data, showLegend = showLegend, ...)

    ## only look at these dose levels for the plot:
    xLevels <-
      if (extrapolate) {
        seq_along(data@doseGrid)
      } else {
        1:max(data@xLevel)
      }

    ## get the plot data for the biomarker plot
    functionSamples <- biomarker(xLevel = xLevels, model = y, samples = x)

    ## extract mean curve
    meanCurve <- colMeans(functionSamples)

    ## extract quantiles
    quantiles <- c(0.025, 0.975)
    quantCurve <- apply(functionSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    plotData <- data.frame(
      dose = data@doseGrid[xLevels],
      mean = meanCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    ## make the second plot
    gdata <-
      with(
        plotData,
        data.frame(
          x = rep(dose, 3),
          y = c(mean, lower, upper),
          group = rep(c("mean", "lower", "upper"), each = nrow(plotData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )
    plot2 <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("blue")
      ) +
      labs(
        x = "Dose level",
        y = "Biomarker level"
      )

    plot2 <- plot2 +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )

    ## arrange both plots side by side
    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)


## -------------------------------------------------------------------------------------
## Get fitted dose-tox curve from Samples for 'LogisticIndepBeta' model class
## ------------------------------------------------------------------------------------
#' @describeIn fit This method return a data frame with dose, middle lower and upper quantiles
#' for the dose-DLE curve using DLE samples for \dQuote{LogisticIndepBeta} model class
#' @example examples/Samples-method-fitDLE.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the dose-tox
    ## curve at the dose grid points.
    probSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    ## evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      probSamples[, i] <- prob(
        dose = points[i],
        model,
        object
      )
    }

    ## extract middle curve
    middleCurve <- apply(probSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(probSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)

## -------------------------------------------------------------------------------------
## Get fitted dose-efficacy curve from Samples for 'Effloglog' model class
## ------------------------------------------------------------------------------------

#' @describeIn fit This method returns a data frame with dose, middle, lower, upper quantiles for
#' the dose-efficacy curve using efficacy samples for \dQuote{Effloglog} model class
#' @example examples/Samples-method-fitEff.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "Effloglog",
    data = "DataDual"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the dose-tox
    ## curve at the dose grid points.
    ExpEffSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    ## evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      ExpEffSamples[, i] <- efficacy(
        dose = points[i],
        model,
        object
      )
    }

    ## extract middle curve
    middleCurve <- apply(ExpEffSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(ExpEffSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)
## ==========================================================================================
## --------------------------------------------------------------------
## Get fitted dose-efficacy based on the Efficacy Flexible model
## -------------------------------------------------------------
#' @describeIn fit This method returns a data frame with dose, middle, lower and upper
#' quantiles for the dose-efficacy curve using efficacy samples for \dQuote{EffFlexi}
#' model class
#' @example examples/Samples-method-fitEffFlexi.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "EffFlexi",
    data = "DataDual"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the dose-tox
    ## curve at the dose grid points.
    ExpEffSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    ## evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      ExpEffSamples[, i] <- efficacy(
        dose = points[i],
        model,
        object
      )
    }

    ## extract middle curve
    middleCurve <- apply(ExpEffSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(ExpEffSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)

#' @describeIn fit This method returns a data frame with dose, middle, lower
#' and upper quantiles for the dose-efficacy curve using efficacy samples
#' for the \dQuote{LogisticLogNormalOrdinal} model class
#' @example examples/Sample-methods-fit-LogisticLogNormalOrdinal.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    # Validation
    assert_probability_range(quantiles)
    assert_numeric(points)
    assert_function(middle)

    # Begin
    # Get samples from the dose-tox curve at the dose grid points.
    probSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )
    # Evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      # Now we want to evaluate for the following dose:
      probSamples[, i] <- prob(
        dose = points[i],
        model,
        object,
        ...
      )
    }
    # Extract middle curve
    middleCurve <- apply(probSamples, 2L, FUN = middle)
    # Extract quantiles
    quantCurve <- apply(probSamples, 2L, quantile, prob = quantiles)

    # Create the data frame...
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)
## ==============================================================
## ----------------------------------------------------------------
## Get fitted values at all dose levels from gain samples
## -----------------------------------------------------------------
#' Get the fitted values for the gain values at all dose levels based on
#' a given pseudo DLE model, DLE sample, a pseudo efficacy model, a Efficacy sample
#' and data. This method returns a data frame with dose, middle, lower and upper quantiles
#' of the gain value samples
#'
#' @param DLEmodel the DLE pseudo model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE samples of \code{\linkS4class{Samples}} class object
#' @param Effmodel the efficacy pseudo model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the efficacy samples of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param \dots additional arguments for methods
#'
#' @export
#' @keywords methods
#' @example examples/Samples-method-fitGain.R
setGeneric(
  "fitGain",
  def = function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("fitGain")
  },
  valueClass = "data.frame"
)

#' @describeIn fitGain This method returns a data frame with dose, middle, lower, upper quantiles for
#' the gain values obtained given the DLE and the efficacy samples
#' @param points at which dose levels is the fit requested? default is the dose
#' grid
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#' @example examples/Samples-method-fitGain.R
setMethod(
  "fitGain",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "Samples",
    Effmodel = "ModelEff",
    Effsamples = "Samples",
    data = "DataDual"
  ),
  def = function(
    DLEmodel,
    DLEsamples,
    Effmodel,
    Effsamples,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the gain
    ## at the dose grid points.
    GainSamples <- matrix(
      nrow = size(DLEsamples),
      ncol = length(points)
    )

    ## evaluate the probs, for all gain samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      GainSamples[, i] <- gain(
        dose = points[i],
        DLEmodel,
        DLEsamples,
        Effmodel,
        Effsamples
      )
    }

    ## extract middle curve
    middleCurve <- apply(GainSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(GainSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)
## ---------------------------------------------------------------------------------
## Plot the fitted dose-DLE curve with pseudo DLE model with samples
## -------------------------------------------------------------------------------
#' Plot the fitted dose-DLE curve using a \code{\linkS4class{ModelTox}} class model with samples
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{ModelTox}} model class object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-DLE model fit
#'
#' @example examples/Samples-method-plotModelTox.R
#' @export
#' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "ModelTox"
  ),
  def = function(
    x,
    y,
    data,
    ...,
    xlab = "Dose level",
    ylab = "Probability of DLT [%]",
    showLegend = TRUE
  ) {
    ## check args
    assert_logical(showLegend)

    ## get the fit
    plotData <- fit(
      x,
      model = y,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## make the plot
    gdata <-
      with(
        plotData,
        data.frame(
          x = rep(dose, 3),
          y = c(middle, lower, upper) * 100,
          group = rep(c("mean", "lower", "upper"), each = nrow(plotData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )

    ret <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("red"),
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      labs(
        x = xlab,
        y = ylab
      )

    ret +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
  }
)


# --------------------------------------------------------------------------------------------
## Plot the fitted dose-efficacy curve using a pseudo efficacy model with samples
## -------------------------------------------------------------------------------------------
#' Plot the fitted dose-efficacy curve using a model from \code{\linkS4class{ModelEff}} class
#' with samples
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{ModelEff}} model class object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-efficacy model fit
#'
#' @example examples/Samples-method-plotModelEff.R
#' @export
#' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "ModelEff"
  ),
  def = function(
    x,
    y,
    data,
    ...,
    xlab = "Dose level",
    ylab = "Expected Efficacy",
    showLegend = TRUE
  ) {
    ## check args
    assert_logical(showLegend)

    ## get the fit
    plotData <- fit(
      x,
      model = y,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## make the plot
    gdata <-
      with(
        plotData,
        data.frame(
          x = rep(dose, 3),
          y = c(middle, lower, upper),
          group = rep(c("mean", "lower", "upper"), each = nrow(plotData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )

    ret <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("blue")
      ) +
      labs(
        x = xlab,
        y = ylab
      ) +
      coord_cartesian(xlim = c(0, max(data@doseGrid)))

    ret +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
  }
)

## ----------------------------------------------------------------------------------------
## Plot of fitted dose-DLE curve based on a pseudo DLE model without sample
## -------------------------------------------------------------------------------------
#' Plot of the fitted dose-tox based with a given pseudo DLE model and data without samples
#'
#' @param x the data of \code{\linkS4class{Data}} class object
#' @param y the model of the \code{\linkS4class{ModelTox}} class object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-DLE model plot
#'
#' @example examples/Samples-method-plotModelToxNoSamples.R
#' @export
#' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "Data",
    y = "ModelTox"
  ),
  def = function(
    x,
    y,
    xlab = "Dose level",
    ylab = "Probability of DLE",
    showLegend = TRUE,
    ...
  ) {
    ## check args
    assert_logical(showLegend)

    ## Make sure the right model estimates are use with the given data
    y <- update(object = y, data = x)

    ## create data frame

    plotData <- data.frame(
      dose = x@doseGrid,
      probDLE = prob(
        dose = x@doseGrid,
        model = y
      )
    )
    ## Look for TD30 and TD35
    TD30 <- dose(
      x = 0.30,
      model = y
    )
    TD35 <- dose(
      x = 0.35,
      model = y
    )

    ## make the plot
    gdata <- with(
      plotData,
      data.frame(
        x = dose,
        y = probDLE,
        group = rep("Estimated DLE", each = nrow(plotData)),
        Type = factor(
          rep("Estimated DLE", nrow(plotData)),
          levels = "Estimated DLE"
        )
      )
    )

    gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("red"),
        linewidth = 1.5
      ) +
      labs(
        x = xlab,
        y = ylab
      ) +
      coord_cartesian(ylim = c(0, 1)) +
      scale_linetype_manual(
        breaks = "Estimated DLE",
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
  }
)


## ---------------------------------------------------------------------------------------------
## Plot the fitted dose-efficacy curve given a pseudo efficacy model without samples
## ----------------------------------------------------------------------------------
#' Plot of the fitted dose-efficacy based with a given pseudo efficacy model and data without samples
#'
#' @param x the data of \code{\linkS4class{DataDual}} class object
#' @param y the model of the \code{\linkS4class{ModelEff}} class object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-efficacy model plot
#'
#' @example examples/Samples-method-plotModelEffNoSamples.R
#' @export
#' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "DataDual",
    y = "ModelEff"
  ),
  def = function(
    x,
    y,
    ...,
    xlab = "Dose level",
    ylab = "Expected Efficacy",
    showLegend = TRUE
  ) {
    ## check args
    assert_logical(showLegend)
    y <- update(object = y, data = x)

    ## create data frame

    plotEffData <- data.frame(
      dose = x@doseGrid,
      ExpEff = efficacy(
        dose = x@doseGrid,
        model = y
      )
    )

    ## make the second plot
    ggdata <- with(
      plotEffData,
      data.frame(
        x = dose,
        y = ExpEff,
        group = rep("Estimated Expected Efficacy", each = nrow(plotEffData)),
        Type = factor(
          rep("Estimated Expected Efficacy", nrow(plotEffData)),
          levels = "Estimated Expected Efficacy"
        )
      )
    )

    ## Get efficacy plot
    plot2 <- ggplot(data = ggdata, aes(x = x, y = y, group = group)) +
      xlab("Dose Levels") +
      ylab(paste("Estimated Expected Efficacy")) +
      xlim(c(0, max(x@doseGrid))) +
      geom_line(colour = I("blue"), linewidth = 1.5)

    plot2 +
      geom_line(linewidth = 1.5, colour = "blue")
  }
)

## ----------------------------------------------------------------------------------------------------------
## Plot the gain curve using a pseudo DLE and a pseudo Efficacy model with samples
## ----------------------------------------------------------------------------------------------------
#' Plot the gain curve in addition with the dose-DLE and dose-efficacy curve using a given DLE pseudo model,
#' a DLE sample, a given efficacy pseudo model and an efficacy sample
#'
#' @param DLEmodel the dose-DLE model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE sample of \code{\linkS4class{Samples}} class object
#' @param Effmodel the dose-efficacy model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the efficacy sample of of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the plot
#'
#' @example examples/Samples-method-plotGain.R
#' @export
#' @keywords methods
setGeneric(
  "plotGain",
  def = function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
    standardGeneric("plotGain")
  }
)
#' @describeIn plotGain Standard method
setMethod(
  "plotGain",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "Samples",
    Effmodel = "ModelEff",
    Effsamples = "Samples"
  ),
  def = function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
    ## Get fitted values for probabilities of DLE at all dose levels

    plotDLEData <- fit(
      DLEsamples,
      model = DLEmodel,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## Get fitted values for mean efficacy values at all dose levels
    plotEffData <- fit(
      Effsamples,
      model = Effmodel,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## Get fitted values for gain values at all dose levels
    plotGainData <- fitGain(
      DLEmodel = DLEmodel,
      DLEsamples = DLEsamples,
      Effmodel = Effmodel,
      Effsamples = Effsamples,
      data = data
    )

    ## For each of the dose levels, take the mean for the probabilties of DLE, mean efiicacy values
    ## and gain values. Hence combine them into a data frame

    plotData <- data.frame(
      dose = rep(data@doseGrid, 3),
      values = c(
        plotDLEData$middle,
        plotEffData$middle,
        plotGainData$middle
      )
    )
    ## only the line plots for the mean value of the DLE, efficacy and gain samples
    ## at all dose levels
    gdata <- with(
      plotData,
      data.frame(
        x = dose,
        y = values,
        group = c(
          rep("p(DLE)", length(data@doseGrid)),
          rep("Mean Expected Efficacy", length(data@doseGrid)),
          rep("Gain", length(data@doseGrid))
        ),
        Type = factor("Estimate", levels = "Estimate")
      )
    )

    ggplot(data = gdata, aes(x = x, y = y)) +
      geom_line(aes(group = group, color = group), linewidth = 1.5) +
      scale_colour_manual(
        name = "curves",
        values = c("green3", "blue", "red")
      ) +
      xlab("Dose Level") +
      xlim(c(0, max(data@doseGrid))) +
      ylab(paste("Values")) +
      ylim(c(min(gdata$y), max(gdata$y)))
  }
)

## ----------------------------------------------------------------------------------------------------
## Plot the gain curve using a pseudo DLE and a pseudo Efficacy model without samples
## ----------------------------------------------------------------------------------------------------
#' Plot the gain curve in addition with the dose-DLE and dose-efficacy curve using a given DLE pseudo model,
#' and a given efficacy pseudo model
#'
#' @describeIn plotGain Standard method
#' @param size (`integer`)\cr a vector of length two defining the sizes of
#' the shapes used to identify the doses with, respectively, p(DLE = 0.3) and the
#' maximum gain
#' @param shape (`integer`)\cr a vector of length two defining the shapes
#' used to identify the doses with, respectively, p(DLE = 0.3) and the maximum gain
#'
#' @example examples/Samples-method-plotGainNoSamples.R
#' @export
#' @keywords methods
setMethod(
  "plotGain",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "missing",
    Effmodel = "ModelEff",
    Effsamples = "missing"
  ),
  def = function(
    DLEmodel,
    Effmodel,
    data,
    size = c(8L, 8L),
    shape = c(16L, 17L),
    ...
  ) {
    assert_integer(size, len = 2, any.missing = FALSE, lower = 0, upper = 20)
    assert_integer(
      shape,
      len = 2,
      any.missing = FALSE,
      unique = TRUE,
      lower = 0,
      upper = 25
    )
    ## Make sure the model estimates are corresponds to the input data
    DLEmodel <- update(object = DLEmodel, data = data)
    Effmodel <- update(object = Effmodel, data = data)

    plotData <- data.frame(
      dose = rep(data@doseGrid, 3),
      values = c(
        prob(
          dose = data@doseGrid,
          model = DLEmodel
        ),
        efficacy(
          dose = data@doseGrid,
          model = Effmodel
        ),
        gain(
          dose = data@doseGrid,
          model_dle = DLEmodel,
          model_eff = Effmodel
        )
      )
    )
    gdata <- with(
      plotData,
      data.frame(
        x = dose,
        y = values,
        group = c(
          rep("p(DLE)", length(data@doseGrid)),
          rep("Expected Efficacy", length(data@doseGrid)),
          rep("Gain", length(data@doseGrid))
        ),
        colour = rep(c("blue", "green3", "red")),
        Type = factor("Estimate", levels = "Estimate")
      )
    )

    # if changing the line type is unacceptable, consider
    # https://stackoverflow.com/questions/25632242/filled-and-hollow-shapes-where-the-fill-color-the-line-color
    plot1 <- ggplot(data = gdata, aes(x = x, y = y)) +
      geom_line(
        aes(group = group, linetype = group, colour = group),
        linewidth = 1
      ) +
      scale_colour_manual(
        name = "Curves",
        values = c("blue", "green3", "red")
      ) +
      scale_linetype_manual(
        name = "Curves",
        values = c("solid", "dotted", "dashed")
      ) +
      xlab("Dose Level") +
      ylab(paste("Values"))

    TD30 <- dose(x = 0.3, model = DLEmodel)

    Gainfun <- function(DOSE) {
      -gain(DOSE, model_dle = DLEmodel, model_eff = Effmodel)
    }
    Gstar <- (optim(
      min(data@doseGrid),
      Gainfun,
      method = "L-BFGS-B",
      lower = min(data@doseGrid),
      upper = max(data@doseGrid)
    )$par)
    MaxGain <- -(optim(
      min(data@doseGrid),
      Gainfun,
      method = "L-BFGS-B",
      lower = min(data@doseGrid),
      upper = max(data@doseGrid)
    )$value)

    if ((TD30 < min(data@doseGrid)) | (TD30 > max(data@doseGrid))) {
      plot1 <- plot1
      message(paste("TD30", paste(TD30, " not within dose Grid")))
    } else {
      plot1 <- plot1 +
        geom_point(
          data = data.frame(x = TD30, y = 0.3),
          aes(x = x, y = y),
          colour = "violet",
          shape = 16,
          size = 8
        ) +
        annotate(
          "text",
          label = "p(DLE=0.3)",
          x = TD30 + 1,
          y = 0.2,
          size = 5,
          colour = "violet"
        )
    }

    # Add annotated point estimates to graph
    point_data <- tibble::tibble(
      Text = NA_character_,
      X = NA_real_,
      Y = NA_real_,
      Shape = NA_real_,
      Size = NA_real_,
      Colour = NA_character_,
      .rows = 0
    )

    if ((TD30 < min(data@doseGrid)) | (TD30 > max(data@doseGrid))) {
      message(paste("TD30", paste(TD30, " not within dose Grid")))
    } else {
      point_data <- point_data %>%
        tibble::add_row(
          X = TD30,
          Y = 0.3,
          Shape = shape[1],
          Size = size[1],
          Colour = "violet",
          Text = "p(DLE=0.3)"
        )
    }
    if ((Gstar < min(data@doseGrid)) | (Gstar > max(data@doseGrid))) {
      print(paste("Gstar=", paste(Gstar, " not within dose Grid")))
    } else {
      plot1 <- plot1 +
        geom_point(
          data = data.frame(x = Gstar, y = MaxGain),
          aes(x = x, y = y),
          colour = "green3",
          shape = 17,
          size = 8
        ) +
        annotate(
          "text",
          label = "Max Gain",
          x = Gstar,
          y = MaxGain - 0.1,
          size = 5,
          colour = "green3"
        )
    }
    point_data <- point_data %>%
      tibble::add_row(
        X = Gstar,
        Y = MaxGain,
        Shape = shape[2],
        Size = size[2],
        Colour = "green3",
        Text = "Max Gain"
      )

    plot1 +
      geom_point(
        data = point_data,
        inherit.aes = FALSE,
        aes(
          x = .data$X,
          y = .data$Y,
          shape = as.factor(.data$Shape),
          fill = .data$Colour
        ),
        colour = point_data$Colour,
        size = point_data$Size,
      ) +
      scale_fill_manual(
        name = "Estimates",
        labels = c("p(DLE = 0.3)", "Max Gain"),
        values = point_data$Colour
      ) +
      scale_shape_discrete(
        name = "Estimates",
        labels = c("p(DLE = 0.3)", "Max Gain"),
        breaks = point_data$Shape
      ) +
      guides(
        shape = guide_legend(override.aes = list(color = c("violet", "green3")))
      ) +
      coord_cartesian(
        xlim = c(0, max(data@doseGrid)),
        ylim = c(min(gdata$y), max(gdata$y))
      )
  }
)
## ==========================================================================================

## -------------------------------------------------------------------------------
## Plot of the DLE and efficacy curve sides by side with samples
## -----------------------------------------------------------------------------
#' Plot of the DLE and efficacy curve side by side given a DLE pseudo model,
#' a DLE sample, an efficacy pseudo model and a given efficacy sample
#'
#' @param DLEmodel the pseudo DLE model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE samples of \code{\linkS4class{Samples}} class object
#' @param Effmodel the pseudo efficacy model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the Efficacy samples of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param extrapolate should the biomarker fit be extrapolated to the whole
#' dose grid? (default)
#' @param showLegend should the legend be shown? (not default)
#' @param \dots additional arguments for the parent method
#' \code{\link{plot,Samples,GeneralModel-method}}
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object with the dose-toxicity and dose-efficacy model fits
#'
#' @example examples/Samples-method-plotDualResponses.R
#'
#' @export
#' @keywords methods
setGeneric(
  "plotDualResponses",
  def = function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
    standardGeneric("plotDualResponses")
  }
)

#' @describeIn plotDualResponses function still to be documented
setMethod(
  "plotDualResponses",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "Samples",
    Effmodel = "ModelEff",
    Effsamples = "Samples"
  ),
  def = function(
    DLEmodel,
    DLEsamples,
    Effmodel,
    Effsamples,
    data,
    extrapolate = TRUE,
    showLegend = FALSE,
    ...
  ) {
    assert_logical(extrapolate)
    assert_logical(showLegend)
    ## Get Toxicity plot
    ## get the fit

    plotDLEData <- fit(
      DLEsamples,
      model = DLEmodel,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## make the plot
    gdata <-
      with(
        plotDLEData,
        data.frame(
          x = rep(dose, 3),
          y = c(middle, lower, upper) * 100,
          group = rep(c("mean", "lower", "upper"), each = nrow(plotDLEData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotDLEData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotDLEData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )

    ret1 <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("red"),
      ) +
      labs(
        x = "Dose Levels",
        y = "Probability of DLE [%]"
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
    ## only look at these dose levels for the plot:

    xLevels <- if (extrapolate) {
      seq_along(data@doseGrid)
    } else {
      1:max(data@xLevel)
    }

    ## get the plot data for the efficacy
    functionSamples <- matrix(
      nrow = size(Effsamples),
      ncol = length(xLevels)
    )
    ## evaluate the efficacy for all samples
    for (i in seq_along(xLevels)) {
      ## Now we want to evaluate for the following dose
      functionSamples[, i] <- efficacy(
        dose = data@doseGrid[xLevels[i]],
        model = Effmodel,
        samples = Effsamples
      )
    }
    ## extract mean curve
    meanCurve <- colMeans(functionSamples)

    ## extract quantiles
    quantiles <- c(0.025, 0.975)
    quantCurve <- apply(functionSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    plotEffData <- data.frame(
      dose = data@doseGrid[xLevels],
      mean = meanCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
    ## make the second plot
    ggdata <- with(
      plotEffData,
      data.frame(
        x = rep(dose, 3),
        y = c(mean, lower, upper),
        group = rep(c("mean", "lower", "upper"), each = nrow(plotEffData)),
        Type = factor(
          c(
            rep(
              "Estimate",
              nrow(plotEffData)
            ),
            rep(
              "95% Credible Interval",
              nrow(plotEffData) * 2
            )
          ),
          levels = c(
            "Estimate",
            "95% Credible Interval"
          )
        )
      )
    )

    plot2 <- ggdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("blue"),
      ) +
      labs(
        x = "Dose level",
        y = "Expected Efficacy"
      ) +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )

    ## arrange both plots side by side
    gridExtra::arrangeGrob(ret1, plot2, ncol = 2)
  }
)

## ------------------------------------------------------------------------------
## Plot of the DLE and efficacy curve sides by side without  samples
## -----------------------------------------------------------------------------
#' Plot of the dose-DLE and dose-efficacy curve side by side given a DLE pseudo model
#' and a given pseudo efficacy model without DLE and efficacy samples
#'
#' @describeIn plotDualResponses Plot the DLE and efficacy curve side by side given a DLE model
#' and an efficacy model without any samples
#'
#' @example examples/Samples-method-plotDualResponsesNoSamples.R
#'
#' @export
#' @keywords methods
setMethod(
  "plotDualResponses",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "missing",
    Effmodel = "ModelEff",
    Effsamples = "missing"
  ),
  def = function(DLEmodel, Effmodel, data, ...) {
    ## Get Toxicity plot
    ## get the fit

    ## Make sure the model estimates are corresponds to the input data
    DLEmodel <- update(object = DLEmodel, data = data)
    Effmodel <- update(object = Effmodel, data = data)

    plotDLEData <- data.frame(
      dose = data@doseGrid,
      probDLE = prob(
        dose = data@doseGrid,
        model = DLEmodel
      )
    )
    ## make the plot
    gdata <- with(
      plotDLEData,
      data.frame(
        x = dose,
        y = probDLE,
        group = rep("Estimated DLE", each = nrow(plotDLEData)),
        Type = factor(
          rep("Estimated DLE", nrow(plotDLEData)),
          levels = "Estimated DLE"
        )
      )
    )

    plot1 <- ggplot(data = gdata, aes(x = x, y = y, group = group)) +
      xlab("Dose Levels") +
      ylab(paste("Probability of DLE")) +
      ylim(c(0, 1)) +
      xlim(c(0, max(data@doseGrid))) +
      geom_line(colour = I("red"), linewidth = 1.5)

    plot1 <- plot1 +
      geom_line(linewidth = 1.5, colour = "red")

    ## only look at these dose levels for the plot:

    ## get the plot data for the efficacy
    plotEffData <- data.frame(
      dose = data@doseGrid,
      ExpEff = efficacy(
        dose = data@doseGrid,
        model = Effmodel
      )
    )

    ## make the second plot
    ggdata <- with(
      plotEffData,
      data.frame(
        x = dose,
        y = ExpEff,
        group = rep("Estimated Expected Efficacy", each = nrow(plotEffData)),
        Type = factor(
          rep("Estimated Expected Efficacy", nrow(plotEffData)),
          levels = "Estimated Expected Efficacy"
        )
      )
    )

    ## Get efficacy plot
    plot2 <- ggplot(data = ggdata, aes(x = x, y = y, group = group)) +
      xlab("Dose Levels") +
      ylab(paste("Estimated Expected Efficacy")) +
      xlim(c(0, max(data@doseGrid))) +
      geom_line(colour = I("blue"), linewidth = 1.5)

    plot2 <- plot2 +
      geom_line(linewidth = 1.5, colour = "blue")

    ## arrange both plots side by side
    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)
## =======================================================================================================

## ----------------------------------------------------------------
## Get fitted DLT free survival (piecewise exponential model) based on
## the DA-CRM model
## -----------------------------------------------------------------
#' Get the fitted DLT free survival (piecewise exponential model).
#' This function returns a data frame with dose, middle, lower and upper
#' quantiles for the `PEM` curve. If hazard=TRUE,
#' @param object mcmc samples
#' @param model the mDA-CRM model
#' @param data the data input, a \code{\linkS4class{DataDA}} class object
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#' @param hazard should the the hazard over time be plotted based on the `PEM`? (not default)
#'   Otherwise ...
#' @param \dots additional arguments for methods
#'
#' @export
#' @keywords methods
setGeneric(
  "fitPEM",
  def = function(
    object,
    model,
    data,
    quantiles = c(0.025, 0.975),
    middle = mean,
    hazard = FALSE,
    ...
  ) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("fitPEM")
  },
  valueClass = "data.frame"
)


#' Likelihood of DLTs in each interval
#'
#' This is a helper function for the `fitPEM` methods below.
#'
#' @param lambda the vector of piecewise hazards
#' @param Tmax the end of the time interval for DLTs
#' @return vector with the probabilities for DLTs within the intervals.
#'
#' @keywords internal
DLTLikelihood <- function(lambda, Tmax) {
  npiece <- length(lambda)
  h <- seq(from = 0L, to = Tmax, length = npiece + 1)

  # Length of each time interval;
  sT <- rep(0, npiece)

  for (i in 1:npiece) {
    sT[i] <- h[i + 1] - h[i]
  }

  # calculate the exponential part of the distribution:
  s_ij <- function(t, j) {
    if (t > h[j]) {
      min(t - h[j], h[j + 1] - h[j])
    } else {
      0
    }
  }

  # The cumulative hazard function
  expNmu <- function(t) {
    ret <- 1
    for (j in 1:npiece) {
      ret <- ret * exp(-lambda[j] * s_ij(t, j))
    }
    ret
  }

  # CDF of the piecewise exponential
  piece_exp_cdf <- function(x) {
    1 - expNmu(x)
  }

  DLTFreeS <- function(x) {
    (expNmu(x) - expNmu(Tmax)) / piece_exp_cdf(Tmax)
  }

  pDLT <- rep(0, npiece + 1)

  for (i in 1:(npiece)) {
    pDLT[i] <- DLTFreeS(h[i]) - DLTFreeS(h[i + 1])
  }

  pDLT
}

## --------------------------------------------------------------------
## Get fitted DLT free survival (piecewise exponential model) based on
## the DA-CRM model
## -------------------------------------------------------------
#' @describeIn fitPEM This method works for the \code{\linkS4class{DALogisticLogNormal}}
#' model class.
#' @example examples/Samples-method-fitPEM-DALogisticLogNormal.R
setMethod(
  "fitPEM",
  signature = signature(
    object = "Samples",
    model = "DALogisticLogNormal",
    data = "DataDA"
  ),
  def = function(
    object,
    model,
    data,
    quantiles = c(0.025, 0.975),
    middle = mean,
    hazard = FALSE,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_logical(hazard)
    ## Plot points
    points <- seq(0, data@Tmax, length = model@npiece + 1)
    ## first we have to get samples from the PEM
    ## at intercept points and 2 middel points between
    ## intercepts.
    PEMSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    i_max <- max(seq_along(points))
    ## evaluate the probs, for all samples.

    # The PEM
    if (hazard == FALSE) {
      PEMSamples <- t(apply(object@data$lambda, 1, function(x) {
        DLTLikelihood(x, data@Tmax)
      }))
    } else if (hazard == TRUE) {
      for (i in seq_along(points)) {
        if (i == i_max) {
          PEMSamples[, i_max] <- object@data$lambda[, model@npiece]
        } else {
          PEMSamples[, i] <- object@data$lambda[, i]
        }
      }
    }

    ## extract middle curve
    middleCurve <- apply(PEMSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(PEMSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    data.frame(
      time = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)

## =======================================================================================================

## --------------------------------------------------
## Plot survival curve fit over time
## --------------------------------------------------

## todo: add example file
#' Plotting dose-toxicity model fits
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{DALogisticLogNormal}} object
#' @param data the \code{\linkS4class{DataDA}} object
#' @param hazard see \code{\link{fitPEM}} for the explanation
#' @param \dots not used
#' @param showLegend should the legend be shown? (default)
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-toxicity model fit
#'
#' @export
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "DALogisticLogNormal"
  ),
  def = function(x, y, data, hazard = FALSE, ..., showLegend = TRUE) {
    ## check args
    assert_logical(showLegend)
    assert_logical(hazard)

    ## call the superclass method, to get the toxicity plot
    plot1 <- callNextMethod(x, y, data, showLegend = showLegend, ...)

    ## get the fit
    fitData <- fitPEM(
      x,
      model = y,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean,
      hazard = hazard
    )

    ## make the plot
    Tpoints <- seq(0, data@Tmax, length = y@npiece + 1)
    plotData <-
      with(
        fitData,
        data.frame(
          x = rep(Tpoints, 3),
          y = c(middle, lower, upper) * 100,
          group = rep(c("mean", "lower", "upper"), each = nrow(fitData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(fitData)
              ),
              rep(
                "95% Credible Interval",
                nrow(fitData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )
    plot2 <- plotData %>%
      ggplot() +
      geom_step(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("blue")
      ) +
      labs(
        x = "Time",
        y = if (hazard) "Hazard rate*100" else "Probability of DLT [%]"
      ) +
      coord_cartesian(
        ylim = if (hazard) range(plotData$y) else c(0, 100)
      )

    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)


## =======================================================================================================

# tidy ----

## Samples

## tidy-Samples ----

#' @rdname tidy
#' @aliases tidy-Samples
#' @example examples/Samples-method-tidy.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "Samples"),
  definition = function(x, ...) {
    rv <- lapply(
      slotNames(x),
      function(nm) {
        if (nm == "data") {
          lapply(
            names(x@data),
            function(nm) {
              as_tibble(get(x, nm))
            }
          ) %>%
            dplyr::bind_rows() %>%
            tidyr::pivot_wider(
              names_from = Parameter,
              values_from = value
            ) %>%
            dplyr::bind_cols(h_handle_attributes(get(x, names(x@data)[1])))
        } else {
          slot(x, nm) %>%
            tidy() %>%
            dplyr::bind_cols()
        }
      }
    )
    names(rv) <- c("data", "options")
    rv <- rv %>% h_tidy_class(x)
    rv
  }
)

#' @include helpers.R
#' @include Data-class.R
#' @include Simulations-validity.R
#' @include CrmPackClass-class.R
NULL

# GeneralSimulations ----

## class ----

#' `GeneralSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures trial simulations.
#' Here also the random generator state before starting the simulation is
#' saved, in order to be able to reproduce the outcome. For this just use
#' [`set.seed`] with the `seed` as argument before running
#' [`simulate,Design-method`].
#'
#' @slot data (`list`)\cr produced [`Data`] objects.
#' @slot doses (`numeric`)\cr final dose recommendations.
#' @slot seed (`integer`)\cr random generator state before starting the simulation.
#'
#' @aliases GeneralSimulations
#' @export
.GeneralSimulations <-
  setClass(
    Class = "GeneralSimulations",
    slots = c(
      data = "list",
      doses = "numeric",
      seed = "integer"
    ),
    prototype = prototype(
      data = list(
        Data(
          x = 1:2,
          y = 0:1,
          doseGrid = 1:2,
          ID = 1L:2L,
          cohort = 1L:2L
        ),
        Data(
          x = 3:4,
          y = 0:1,
          doseGrid = 3:4,
          ID = 1L:2L,
          cohort = 1L:2L
        )
      ),
      doses = c(1, 2),
      seed = 1L
    ),
    contains = "CrmPackClass",
    validity = v_general_simulations
  )

## constructor ----

#' @rdname GeneralSimulations-class
#'
#' @param data (`list`)\cr see slot definition.
#' @param doses (`numeric`)\cr see slot definition.
#' @param seed (`integer`)\cr see slot definition.
#'
#' @example examples/Simulations-class-GeneralSimulations.R
#' @export
GeneralSimulations <- function(data, doses, seed) {
  assert_integerish(seed)
  .GeneralSimulations(
    data = data,
    doses = doses,
    seed = as.integer(seed)
  )
}


## default constructor

#' @rdname GeneralSimulations-class
#' @note Typically, end users will not use the `.DefaultGeneralSimulations()` function.
#' @export
.DefaultGeneralSimulations <- function() {
  GeneralSimulations(
    data = list(
      Data(x = 1:3, y = c(0, 1, 0), doseGrid = 1:3, ID = 1L:3L, cohort = 1L:3L),
      Data(x = 4:6, y = c(0, 1, 0), doseGrid = 4:6, ID = 1L:3L, cohort = 1L:3L)
    ),
    doses = c(1, 2),
    seed = 123
  )
}


# Simulations ----

## class ----

#' `Simulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from model based designs.
#' Additional slots `fit`, `stop_reasons`, `stop_report`,`additional_stats` compared to
#' the general class [`GeneralSimulations`].
#'
#' @slot fit (`list`)\cr final fits
#' @slot stop_reasons (`list`)\cr stopping reasons for each simulation run
#' @slot stop_report matrix of stopping rule outcomes
#' @slot additional_stats list of additional statistical summary
#' @aliases Simulations
#' @export
.Simulations <-
  setClass(
    Class = "Simulations",
    slots = c(
      fit = "list",
      stop_report = "matrix",
      stop_reasons = "list",
      additional_stats = "list"
    ),
    prototype = prototype(
      fit = list(
        c(0.1, 0.2),
        c(0.1, 0.2)
      ),
      stop_report = matrix(TRUE, nrow = 2),
      stop_reasons = list("A", "A"),
      additional_stats = list(a = 1, b = 1)
    ),
    contains = "GeneralSimulations",
    validity = v_simulations
  )

## constructor ----

#' @rdname Simulations-class
#'
#' @param fit (`list`)\cr see slot definition.
#' @param stop_reasons (`list`)\cr see slot definition.
#' @param stop_report see [`Simulations`]
#' @param additional_stats (`list`)\cr see slot definition.
#' @param \dots additional parameters from [`GeneralSimulations`]
#'
#' @example examples/Simulations-class-Simulations.R
#' @export
Simulations <- function(fit, stop_reasons, stop_report, additional_stats, ...) {
  start <- GeneralSimulations(...)
  .Simulations(
    start,
    fit = fit,
    stop_report = stop_report,
    stop_reasons = stop_reasons,
    additional_stats = additional_stats
  )
}

## default constructor ----

#' @rdname Simulations-class
#' @note Typically, end users will not use the `.DefaultSimulations()` function.
#' @export
.DefaultSimulations <- function() {
  design <- .DefaultDesign()
  myTruth <- probFunction(design@model, alpha0 = 7, alpha1 = 8)

  simulate(
    design,
    args = NULL,
    truth = myTruth,
    nsim = 1,
    seed = 819,
    mcmcOptions = .DefaultMcmcOptions(),
    parallel = FALSE
  )
}

# DualSimulations ----

## class ----

#' `DualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from dual-endpoint model based
#' designs. In comparison to the parent class [`Simulations`],
#' it contains additional slots to capture the dose-biomarker `fits`, and the
#' `sigma2W` and `rho` estimates.
#'
#' @slot rho_est (`numeric`)\cr vector of final posterior median rho estimates
#' @slot sigma2w_est (`numeric`)\cr vector of final posterior median sigma2W estimates
#' @slot fit_biomarker (`list`)\cr with the final dose-biomarker curve fits
#' @aliases DualSimulations
#' @export
.DualSimulations <-
  setClass(
    Class = "DualSimulations",
    slots = c(
      rho_est = "numeric",
      sigma2w_est = "numeric",
      fit_biomarker = "list"
    ),
    prototype = prototype(
      rho_est = c(0.2, 0.3),
      sigma2w_est = c(0.2, 0.3),
      fit_biomarker = list(
        c(0.1, 0.2),
        c(0.1, 0.2)
      )
    ),
    contains = "Simulations",
    validity = v_dual_simulations
  )


## constructor ----

#' @rdname DualSimulations-class
#'
#' @param rho_est (`numeric`)\cr see [`DualSimulations`]
#' @param sigma2w_est (`numeric`)\cr [`DualSimulations`]
#' @param fit_biomarker (`list`)\cr see [`DualSimulations`]
#' @param \dots additional parameters from [`Simulations`]
#'
#' @example examples/Simulations-class-DualSimulations.R
#' @export
DualSimulations <- function(rho_est, sigma2w_est, fit_biomarker, ...) {
  start <- Simulations(...)
  .DualSimulations(
    start,
    rho_est = rho_est,
    sigma2w_est = sigma2w_est,
    fit_biomarker = fit_biomarker
  )
}

## default constructor ----

#' @rdname DualSimulations-class
#' @note Typically, end users will not use the `.DefaultDualSimulations()` function.
#' @export
.DefaultDualSimulations <- function() {
  DualSimulations(
    rho_est = c(0.25, 0.35),
    sigma2w_est = c(0.15, 0.25),
    fit_biomarker = list(c(0.3, 0.4), c(0.4, 0.5)),
    fit = list(
      c(0.1, 0.2),
      c(0.3, 0.4)
    ),
    stop_report = matrix(c(TRUE, FALSE), nrow = 2),
    stop_reasons = list("A", "B"),
    additional_stats = list(a = 1, b = 1),
    data = list(
      Data(
        x = 1:2,
        y = 0:1,
        doseGrid = 1:2,
        ID = 1L:2L,
        cohort = 1L:2L
      ),
      Data(
        x = 3:4,
        y = 0:1,
        doseGrid = 3:4,
        ID = 1L:2L,
        cohort = 1L:2L
      )
    ),
    doses = c(1, 2),
    seed = 123L
  )
}

#' `GeneralSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the summary of general simulations output. Note that objects
#' should not be created by users, therefore no initialization
#' function is provided for this class.
#'
#' @slot target (`numeric`)\cr target toxicity interval
#' @slot target_dose_interval (`numeric`)\cr corresponding target dose interval
#' @slot nsim (`integer`)\cr number of simulations
#' @slot prop_dlts (`ANY`)\cr A numeric array (multi-dimensional) or list representing proportions of DLTs in the trials
#' @slot mean_tox_risk (`numeric`)\cr mean toxicity risks for the patients
#' @slot dose_selected (`numeric`)\cr doses selected as MTD
#' @slot tox_at_doses_selected (`numeric`)\cr true toxicity at doses selected
#' @slot prop_at_target (`numeric`)\cr Proportion of trials selecting target MTD
#' @slot dose_most_selected (`numeric`)\cr dose most often selected as MTD
#' @slot obs_tox_rate_at_dose_most_selected (`numeric`)\cr observed toxicity rate at dose most often selected
#' @slot n_obs (`ANY`)\cr A numeric array (multi-dimensional) or list representing number of patients overall.
#' @slot n_above_target (`integer`)\cr number of patients treated above target tox interval
#' @slot dose_grid (`numeric`)\cr the dose grid that has been used
#' @slot placebo (`logical`)\cr set to TRUE (default is FALSE) for a design with placebo
#' @aliases GeneralSimulationsSummary
#' @export
.GeneralSimulationsSummary <-
  setClass(
    Class = "GeneralSimulationsSummary",
    slots = c(
      target = "numeric",
      target_dose_interval = "numeric",
      nsim = "integer",
      prop_dlts = "ANY",
      mean_tox_risk = "numeric",
      dose_selected = "numeric",
      tox_at_doses_selected = "numeric",
      prop_at_target = "numeric",
      dose_most_selected = "numeric",
      obs_tox_rate_at_dose_most_selected = "numeric",
      n_obs = "ANY",
      n_above_target = "integer",
      dose_grid = "numeric",
      placebo = "logical"
    )
  )

## default constructor ----

#' @rdname GeneralSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultGeneralSimulationsSummary()` function.
#' @export
.DefaultGeneralSimulationsSummary <- function() {
  stop(
    paste(
      "Class GeneralSimulationsSummary cannot be instantiated directly.",
      "Please use one of its subclasses instead."
    )
  )
}

## SimulationsSummary ----

## class ----

#' `SimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' In addition to the slots in the parent class [`GeneralSimulationsSummary`],
#' it contains two slots with model fit information.
#'
#' @slot stop_report (`matrix`)\cr matrix of stopping rule outcomes
#' @slot fit_at_dose_most_selected (`numeric`)\cr fitted toxicity rate at dose most often selected
#' @slot additional_stats (`list`)\cr list of additional statistical summary
#' @slot mean_fit (`list`)\cr list with the average, lower (2.5%) and upper (97.5%)
#' quantiles of the mean fitted toxicity at each dose level
#'
#' @aliases SimulationsSummary
#' @export
.SimulationsSummary <-
  setClass(
    Class = "SimulationsSummary",
    slots = c(
      stop_report = "matrix",
      fit_at_dose_most_selected = "numeric",
      additional_stats = "list",
      mean_fit = "list"
    ),
    contains = "GeneralSimulationsSummary"
  )

## default constructor ----

#' @rdname SimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultSimulationsSummary()` function.
#' @export
.DefaultSimulationsSummary <- function() {
  stop(paste(
    "Class SimulationsSummary cannot be instantiated directly.",
    "Please use one of its subclasses instead."
  ))
}

# DualSimulationsSummary ----

# class ----

#' `DualSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#' This class captures the summary of dual-endpoint simulations output.
#' In comparison to its parent class [`SimulationsSummary`], it has additional slots.
#'
#' @slot biomarker_fit_at_dose_most_selected (`numeric`)\cr fitted biomarker level at most often selected dose.
#' @slot mean_biomarker_fit (`list`)\cr list with average, lower (2.5%) and upper (97.5%) quantiles of
#' mean fitted biomarker level at each dose
#' @aliases DualSimulationsSummary
#' @export
.DualSimulationsSummary <-
  setClass(
    Class = "DualSimulationsSummary",
    slots = c(
      biomarker_fit_at_dose_most_selected = "numeric",
      mean_biomarker_fit = "list"
    ),
    contains = "SimulationsSummary"
  )

# default constructor

#' @rdname DualSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultDualSimulationsSummary()` function.
#' @export
.DefaultDualSimulationsSummary <- function() {
  empty_data <- DataDual(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 30))

  my_model <- DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2betaW = 0.01,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    rw1 = TRUE
  )

  my_next_best <- NextBestDualEndpoint(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  my_stopping1 <- StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5
  )

  my_stopping <- my_stopping1 | StoppingMinPatients(10) | StoppingMissingDose()

  my_increments <- IncrementsRelative(
    intervals = c(0, 20),
    increments = c(1, 0.33)
  )

  my_design <- DualDesign(
    model = my_model,
    data = empty_data,
    nextBest = my_next_best,
    stopping = my_stopping,
    increments = my_increments,
    cohort_size = CohortSizeConst(3),
    startingDose = 3
  )

  beta_mod <- function(dose, e0, eMax, delta1, delta2, scal) {
    maxDens <- (delta1^delta1) *
      (delta2^delta2) /
      ((delta1 + delta2)^(delta1 + delta2))
    dose <- dose / scal
    e0 + eMax / maxDens * (dose^delta1) * (1 - dose)^delta2
  }

  true_biomarker <- function(dose) {
    beta_mod(
      dose,
      e0 = 0.2,
      eMax = 0.6,
      delta1 = 5,
      delta2 = 5 * 0.5 / 0.5,
      scal = 100
    )
  }

  true_tox <- function(dose) {
    pnorm((dose - 60) / 10)
  }

  x <- simulate(
    object = my_design,
    trueTox = true_tox,
    trueBiomarker = true_biomarker,
    sigma2W = 0.01,
    rho = 0,
    nsim = 1,
    parallel = FALSE,
    seed = 3,
    startingDose = 6,
    mcmcOptions = .DefaultMcmcOptions()
  )
}

# PseudoSimulations ----

## class ----

#' `PseudoSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#' This class captures trial simulations from designs using pseudo model.
#' It has additional slots `fit` and `stop_reasons` compared to the
#' general class [`GeneralSimulations`].
#'
#' @slot fit (`list`)\cr final fit values.
#' @slot final_td_target_during_trial_estimates (`numeric`)\cr final estimates of the `td_target_during_trial`.
#' @slot final_td_target_end_of_trial_estimates (`numeric`)\cr final estimates of the `td_target_end_of_trial`.
#' @slot final_td_target_during_trial_at_dose_grid (`numeric`)
#'        \cr dose levels at dose grid closest below the final `td_target_during_trial` estimates.
#' @slot final_td_target_end_of_trial_at_dose_grid (`numeric`)
#'        \cr dose levels at dose grid closest below the final `td_target_end_of_trial` estimates.
#' @slot final_tdeot_cis (`list`)\cr 95% credibility intervals of the final estimates for `td_target_end_of_trial`.
#' @slot final_tdeot_ratios (`numeric`)\cr ratio of the upper to the lower 95%
#'        credibility intervals for `td_target_end_of_trial`.
#' @slot final_cis (`list`)\cr final 95% credibility intervals for `td_target_end_of_trial` estimates.
#' @slot final_ratios (`numeric`)\cr final ratios of the upper to the lower 95%
#'        credibility interval for `td_target_end_of_trial`.
#' @slot stop_report (`matrix`)\cr outcomes of stopping rules.
#' @slot stop_reasons (`list`)\cr reasons for stopping each simulation run.
#'
#' @aliases PseudoSimulations
#' @export
.PseudoSimulations <-
  setClass(
    Class = "PseudoSimulations",
    slots = c(
      fit = "list",
      final_td_target_during_trial_estimates = "numeric",
      final_td_target_end_of_trial_estimates = "numeric",
      final_td_target_during_trial_at_dose_grid = "numeric",
      final_td_target_end_of_trial_at_dose_grid = "numeric",
      final_tdeot_cis = "list",
      final_tdeot_ratios = "numeric",
      final_cis = "list",
      final_ratios = "numeric",
      stop_report = "matrix",
      stop_reasons = "list"
    ),
    prototype = prototype(
      final_td_target_during_trial_estimates = c(0.1, 0.1),
      final_td_target_end_of_trial_estimates = c(0.1, 0.1),
      final_td_target_during_trial_at_dose_grid = c(0.1, 0.1),
      final_td_target_end_of_trial_at_dose_grid = c(0.1, 0.1),
      final_tdeot_cis = list(c(0.1, 0.2), c(0.1, 0.2)),
      final_tdeot_ratios = c(0.1, 0.1),
      final_cis = list(c(0.1, 0.2), c(0.1, 0.2)),
      final_ratios = c(0.1, 0.1),
      stop_report = matrix(TRUE, nrow = 2),
      stop_reasons = list("A", "A")
    ),
    contains = "GeneralSimulations",
    validity = v_pseudo_simulations
  )

## constructor ----

#' @rdname PseudoSimulations-class
#'
#' @param fit (`list`)\cr see slot definition.
#' @param final_td_target_during_trial_estimates (`numeric`)\cr see slot definition.
#' @param final_td_target_end_of_trial_estimates (`numeric`)\cr see slot definition.
#' @param final_td_target_during_trial_at_dose_grid (`numeric`)\cr see slot definition.
#' @param final_td_target_end_of_trial_at_dose_grid (`numeric`)\cr see slot definition.
#' @param final_tdeot_cis (`list`)\cr see slot definition.
#' @param final_tdeot_ratios (`numeric`)\cr see slot definition.
#' @param final_cis (`list`)\cr see slot definition.
#' @param final_ratios (`numeric`)\cr see slot definition.
#' @param stop_report see [`PseudoSimulations`]
#' @param stop_reasons (`list`)\cr see slot definition.
#' @param \dots additional parameters from [`GeneralSimulations`]
#'
#' @export
PseudoSimulations <- function(
  fit,
  final_td_target_during_trial_estimates,
  final_td_target_end_of_trial_estimates,
  final_td_target_during_trial_at_dose_grid,
  final_td_target_end_of_trial_at_dose_grid,
  final_tdeot_cis,
  final_tdeot_ratios,
  final_cis,
  final_ratios,
  stop_report,
  stop_reasons,
  ...
) {
  start <- GeneralSimulations(...)
  .PseudoSimulations(
    start,
    fit = fit,
    final_td_target_during_trial_estimates = final_td_target_during_trial_estimates,
    final_td_target_end_of_trial_estimates = final_td_target_end_of_trial_estimates,
    final_td_target_during_trial_at_dose_grid = final_td_target_during_trial_at_dose_grid,
    final_td_target_end_of_trial_at_dose_grid = final_td_target_end_of_trial_at_dose_grid,
    final_tdeot_cis = final_tdeot_cis,
    final_tdeot_ratios = final_tdeot_ratios,
    final_cis = final_cis,
    final_ratios = final_ratios,
    stop_report = stop_report,
    stop_reasons = stop_reasons
  )
}

## default constructor ----

#' @rdname PseudoSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoSimulations()` function.
#' @export
.DefaultPseudoSimulations <- function() {
  stop(
    "Class PseudoSimulations cannot be instantiated directly. Please use one of its subclasses instead."
  )
}

# PseudoDualSimulations ----

## class ----

#' `PseudoDualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#' This class conducts trial simulations for designs using both the
#' DLE and efficacy responses. It defines final values for
#' efficacy fit and DLE, estimates of Gstar, optimal dose and sigma2.
#'
#' @slot fit_eff (`list`)\cr final values of efficacy fit.
#' @slot final_gstar_estimates (`numeric`)\cr final Gstar estimates.
#' @slot final_gstar_at_dose_grid (`numeric`)\cr final Gstar estimates at dose grid.
#' @slot final_gstar_cis (`list`)\cr list of 95% confidence interval for Gstar estimates.
#' @slot final_gstar_ratios (`numeric`)\cr ratios of confidence intervals for Gstar estimates.
#' @slot final_optimal_dose (`numeric`)\cr final optimal dose.
#' @slot final_optimal_dose_at_dose_grid (`numeric`)\cr final optimal dose at dose grid.
#' @slot sigma2_est (`numeric`)\cr final sigma2 estimates.
#'
#' @aliases PseudoDualSimulations
#' @export
.PseudoDualSimulations <-
  setClass(
    Class = "PseudoDualSimulations",
    slots = c(
      fit_eff = "list",
      final_gstar_estimates = "numeric",
      final_gstar_at_dose_grid = "numeric",
      final_gstar_cis = "list",
      final_gstar_ratios = "numeric",
      final_optimal_dose = "numeric",
      final_optimal_dose_at_dose_grid = "numeric",
      sigma2_est = "numeric"
    ),
    prototype = prototype(
      final_gstar_estimates = c(0.1, 0.1),
      final_gstar_at_dose_grid = c(0.1, 0.1),
      final_gstar_cis = list(c(0.1, 0.2), c(0.1, 0.2)),
      final_gstar_ratios = c(0.01, 0.01),
      final_optimal_dose = c(0.01, 0.01),
      final_optimal_dose_at_dose_grid = c(0.01, 0.01),
      sigma2_est = c(0.001, 0.002)
    ),
    contains = "PseudoSimulations",
    validity = v_pseudo_dual_simulations
  )

## constructor ----

#' @rdname PseudoDualSimulations-class
#'
#' @param fit_eff (`list`)\cr see slot definition.
#' @param final_gstar_estimates (`numeric`)\cr see slot definition.
#' @param final_gstar_at_dose_grid (`numeric`)\cr see slot definition.
#' @param final_gstar_cis (`list`)\cr see slot definition.
#' @param final_gstar_ratios (`numeric`)\cr see slot definition.
#' @param final_optimal_dose (`numeric`)\cr see slot definition.
#' @param final_optimal_dose_at_dose_grid (`numeric`)\cr see slot definition.
#' @param sigma2_est (`numeric`)\cr see slot definition.
#' @param \dots additional parameters from [`PseudoSimulations`]
#' @export
PseudoDualSimulations <- function(
  fit_eff,
  final_gstar_estimates,
  final_gstar_at_dose_grid,
  final_gstar_cis,
  final_gstar_ratios,
  final_optimal_dose,
  final_optimal_dose_at_dose_grid,
  sigma2_est,
  ...
) {
  start <- PseudoSimulations(...)
  .PseudoDualSimulations(
    start,
    fit_eff = fit_eff,
    final_gstar_estimates = final_gstar_estimates,
    final_gstar_at_dose_grid = final_gstar_at_dose_grid,
    final_gstar_cis = final_gstar_cis,
    final_gstar_ratios = final_gstar_ratios,
    final_optimal_dose = final_optimal_dose,
    final_optimal_dose_at_dose_grid = final_optimal_dose_at_dose_grid,
    sigma2_est = sigma2_est
  )
}

## default constructor ----

#' @rdname PseudoDualSimulations-class
#' @note Do not use the `.DefaultPseudoDualSimulations()` function.
#' @export
.DefaultPseudoDualSimulations <- function() {
  stop(
    "Class PseudoDualSimulations cannot be instantiated directly. Please use a subclass."
  )
}

# PseudoDualFlexiSimulations ----

## class ----

#' `PseudoDualFlexiSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#' This class captures the trial simulations design using both the DLE and
#' efficacy responses using [`EffFlexi`] efficacy model.
#' It extends [`PseudoDualSimulations`] by adding the capability to capture the sigma2betaW estimates.
#'
#' @slot sigma2_beta_w_est (`numeric`)\cr the vector of the final posterior mean sigma2betaW estimates
#' @aliases PseudoDualFlexiSimulations
#' @export
.PseudoDualFlexiSimulations <-
  setClass(
    Class = "PseudoDualFlexiSimulations",
    slots = c(sigma2_beta_w_est = "numeric"),
    prototype = prototype(sigma2_beta_w_est = c(0.001, 0.002)),
    contains = "PseudoDualSimulations"
  )

## constructor ----

#' @rdname PseudoDualFlexiSimulations-class
#'
#' @param sigma2_beta_w_est (`numeric`)\cr the vector of the final posterior mean sigma2betaW estimates
#' @param \dots additional parameters from [`PseudoDualSimulations`]
#'
#' @export
PseudoDualFlexiSimulations <- function(sigma2_beta_w_est, ...) {
  start <- PseudoDualSimulations(...)
  .PseudoDualFlexiSimulations(start, sigma2_beta_w_est = sigma2_beta_w_est)
}

## default constructor ----

#' @rdname PseudoDualFlexiSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoFlexiSimulations()` function.
#' @export
.DefaultPseudoDualFlexiSimulations <- function() {
  stop(
    "Class PseudoFlexiSimulations cannot be instantiated directly. Please use one of its subclasses instead."
  )
}

# PseudoSimulationsSummary ----

## class ----

#' `PseudoSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the summary of pseudo-models simulations output.
#' Note that objects should not be created by users, therefore no
#' initialization function is provided for this class.
#'
#' @slot target_end_of_trial (`numeric`)\cr the target probability of DLE wanted at the end of a trial
#' @slot target_dose_end_of_trial (`numeric`)\cr the dose level corresponds to the target probability
#'   of DLE wanted at the end of a trial, TDEOT
#' @slot target_dose_end_of_trial_at_dose_grid (`numeric`)\cr the dose level at dose grid corresponds to the
#'   target probability of DLE wanted at the end of a trial
#' @slot target_during_trial (`numeric`)\cr the target probability of DLE wanted during a trial
#' @slot target_dose_during_trial (`numeric`)\cr the dose level corresponds to the target probability of DLE
#'   wanted during the trial. TDDT
#' @slot target_dose_during_trial_at_dose_grid (`numeric`)\cr the dose level at dose grid corresponds to the
#'   target probability of DLE wanted during a trial
#' @slot tdeot_summary (`table`)\cr the six-number table summary, include the lowest, the 25th percentile
#'   (lower quartile), the 50th percentile (median), the mean, the 75th percentile and the highest values of the
#'   final dose levels obtained corresponds to the target probability of DLE
#'   want at the end of a trial across all simulations
#' @slot tddt_summary (`table`)\cr the six-number table summary, include the lowest, the 25th percentile
#'   (lower quartile), the 50th percentile (median), the mean, the 75th percentile and the highest values of the
#'   final dose levels obtained corresponds to the target probability of DLE
#'   want during a trial across all simulations
#' @slot final_dose_rec_summary (`table`)\cr the six-number table summary, include the lowest, the 25th percentile
#'   (lower quartile), the 50th percentile (median), the mean, the 75th percentile and the highest values of the
#'   final optimal doses, which is either the TDEOT when only DLE response are incorporated into
#'   the escalation procedure or the minimum of the TDEOT and Gstar when DLE and efficacy responses are
#'   incorporated, across all simulations
#' @slot ratio_tdeot_summary (`table`)\cr the six-number summary table of the final ratios of the upper to the
#'   lower 95% credibility intervals of the final TDEOTs across all simulations
#' @slot final_ratio_summary (`table`)\cr the six-number summary table of the final ratios of the upper to the
#'   lower 95% credibility intervals of the final optimal doses across all simulations
#' @slot nsim (`integer`)\cr number of simulations
#' @slot prop_dle (`numeric`)\cr proportions of DLE in the trials
#' @slot mean_tox_risk (`numeric`)\cr mean toxicity risks for the patients
#' @slot dose_selected (`numeric`)\cr doses selected as MTD (target_dose_end_of_trial)
#' @slot tox_at_doses_selected (`numeric`)\cr true toxicity at doses selected
#' @slot prop_at_target_end_of_trial (`numeric`)\cr Proportion of trials selecting at the dose_grid closest below the
#'   MTD, the target_dose_end_of_trial
#' @slot prop_at_target_during_trial (`numeric`)\cr Proportion of trials selecting at the dose_grid closest below
#'   the target_dose_during_trial
#' @slot dose_most_selected (`numeric`)\cr dose most often selected as MTD
#' @slot obs_tox_rate_at_dose_most_selected (`numeric`)\cr observed toxicity rate at dose most often
#'   selected
#' @slot n_obs (`integer`)\cr number of patients overall
#' @slot n_above_target_end_of_trial (`integer`)\cr number of patients treated above target_dose_end_of_trial
#' @slot n_above_target_during_trial (`integer`)\cr number of patients treated above target_dose_during_trial
#' @slot dose_grid (`numeric`)\cr the dose grid that has been used
#' @slot fit_at_dose_most_selected (`numeric`)\cr fitted toxicity rate at dose most often selected
#' @slot mean_fit (`list`)\cr list with the average, lower (2.5%) and upper (97.5%)
#'   quantiles of the mean fitted toxicity at each dose level
#' @slot stop_report (`matrix`)\cr matrix of stopping rule outcomes
#'
#' @aliases PseudoSimulationsSummary
#' @export
.PseudoSimulationsSummary <-
  setClass(
    Class = "PseudoSimulationsSummary",
    slots = c(
      target_end_of_trial = "numeric",
      target_dose_end_of_trial = "numeric",
      target_dose_end_of_trial_at_dose_grid = "numeric",
      target_during_trial = "numeric",
      target_dose_during_trial = "numeric",
      target_dose_during_trial_at_dose_grid = "numeric",
      tdeot_summary = "table",
      tddt_summary = "table",
      final_dose_rec_summary = "table",
      ratio_tdeot_summary = "table",
      final_ratio_summary = "table",
      nsim = "integer",
      prop_dle = "numeric",
      mean_tox_risk = "numeric",
      dose_selected = "numeric",
      tox_at_doses_selected = "numeric",
      prop_at_target_end_of_trial = "numeric",
      prop_at_target_during_trial = "numeric",
      dose_most_selected = "numeric",
      obs_tox_rate_at_dose_most_selected = "numeric",
      n_obs = "integer",
      n_above_target_end_of_trial = "integer",
      n_above_target_during_trial = "integer",
      dose_grid = "numeric",
      fit_at_dose_most_selected = "numeric",
      mean_fit = "list",
      stop_report = "matrix"
    )
  )

## default constructor ----

#' @rdname PseudoSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultPseudoSimulationsSummary()` function.
#' @export
.DefaultPseudoSimulationsSummary <- function() {
  stop(
    "Class PseudoSimulationsSummary cannot be instantiated directly. Please use one of its subclasses instead."
  )
}

# PseudoDualSimulationsSummary ----

## class ----

#' `PseudoDualSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the summary of the dual responses simulations using pseudo models.
#' It contains all slots from [`PseudoSimulationsSummary`] object. In addition to
#' the slots in the parent class [`PseudoSimulationsSummary`], it contains additional
#' slots for the efficacy model fit information.
#'
#' Note that objects should not be created by users, therefore no initialization function
#' is provided for this class.
#'
#' @slot target_gstar (`numeric`)\cr the target dose level such that its gain value is at maximum
#' @slot target_gstar_at_dose_grid (`numeric`)\cr the dose level at dose Grid closest and below Gstar
#' @slot gstar_summary (`table`)\cr the six-number table summary (lowest, 25th, 50th (median), 75th percentile, mean
#'   and highest value) of the final Gstar values obtained across all simulations
#' @slot ratio_gstar_summary (`table`)\cr the six-number summary table of the ratios of the upper to the lower 95%
#'   credibility intervals of the final Gstar across all simulations
#' @slot eff_fit_at_dose_most_selected (`numeric`)\cr fitted expected mean efficacy value at dose most often
#'   selected
#' @slot mean_eff_fit (`list`)\cr list with mean, lower (2.5%) and upper (97.5%) quantiles of the fitted expected
#'   efficacy value at each dose level.
#'
#' @aliases PseudoDualSimulationsSummary
#' @export
.PseudoDualSimulationsSummary <-
  setClass(
    Class = "PseudoDualSimulationsSummary",
    contains = "PseudoSimulationsSummary",
    slots = c(
      target_gstar = "numeric",
      target_gstar_at_dose_grid = "numeric",
      gstar_summary = "table",
      ratio_gstar_summary = "table",
      eff_fit_at_dose_most_selected = "numeric",
      mean_eff_fit = "list"
    )
  )

## default constructor ----

#' @rdname PseudoDualSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultPseudoDualSimulationsSummary()` function.
#' @export
.DefaultPseudoDualSimulationsSummary <- function() {
  stop(
    "Class PseudoDualSimulationsSummary cannot be instantiated directly. Please use one of its subclasses instead."
  )
}

# DASimulations ----

## class ----

#' `DASimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from DA based designs.
#' In comparison to the parent class [`Simulations`],
#' it contains additional slots to capture the time to DLT fits, additional
#' parameters and the trial duration.
#'
#' @slot trial_duration (`numeric`)\cr the vector of trial duration values for all simulations.
#'
#' @aliases DASimulations
#' @export
.DASimulations <-
  setClass(
    Class = "DASimulations",
    slots = c(trial_duration = "numeric"),
    prototype = prototype(trial_duration = rep(0, 2)),
    contains = "Simulations",
    validity = v_da_simulations
  )

## constructor ----

#' @rdname DASimulations-class
#'
#' @param trial_duration (`numeric`)\cr see [`DASimulations`]
#' @param \dots additional parameters from [`Simulations`]
#'
#' @export
DASimulations <- function(trial_duration, ...) {
  start <- Simulations(...)
  .DASimulations(start, trial_duration = trial_duration)
}


## default constructor ----

#' @rdname DASimulations-class
#' @note Typically, end users will not use the `.DefaultDASimulations()` function.
#' @export
.DefaultDASimulations <- function() {
  design <- .DefaultDADesign()
  myTruth <- probFunction(design@model, alpha0 = 2, alpha1 = 3)
  exp_cond_cdf <- function(x, onset = 15) {
    a <- stats::pexp(28, 1 / onset, lower.tail = FALSE)
    1 - (stats::pexp(x, 1 / onset, lower.tail = FALSE) - a) / (1 - a)
  }

  simulate(
    design,
    args = NULL,
    truthTox = myTruth,
    truthSurv = exp_cond_cdf,
    trueTmax = 80,
    nsim = 2,
    seed = 819,
    mcmcOptions = .DefaultMcmcOptions(),
    firstSeparate = TRUE,
    deescalate = FALSE,
    parallel = FALSE
  )
}

# tidy

## tidy-Simulations ----

#' @rdname tidy
#' @aliases tidy-Simulations
#' @example examples/Simulations-method-tidy.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "Simulations"),
  definition = function(x, ...) {
    slot_names <- slotNames(x)
    rv <- list()
    for (nm in slot_names) {
      if (!is.function(slot(x, nm))) {
        if (nm %in% c("stop_reasons", "additional_stats")) {} else {
          rv[[nm]] <- h_tidy_slot(x, nm)
        }
      }
    }
    # Column bind of all list elements have the same number of rows
    if (length(rv) > 1 & length(unique(sapply(rv, nrow))) == 1) {
      rv <- rv %>% dplyr::bind_cols()
    }
    rv %>% h_tidy_class(x)
  }
)

# assertions ----

#' Additional Assertions for `checkmate`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional assertion functions that can be used together with
#' the `checkmate` functions. These are described in individual help pages
#' linked below.
#'
#' @return Depending on the function prefix.
#' - `assert_` functions return the object invisibly if successful, and otherwise
#'   throw an error message.
#' - `check_` functions return `TRUE` if successful, otherwise a string with the
#'   error message.
#' - `test_` functions just return `TRUE` or `FALSE`.
#'
#' @seealso [assert_probabilities()], [assert_probability()],
#'   [assert_probability_range()], [assert_length()].
#'
#' @name assertions
NULL

# check equality ----

#' Check if All Arguments Are Equal
#'
#' @description `r lifecycle::badge("experimental")`
#' Elements of `...` must be numeric vectors or scalars.
#'
#' This function performs an element-by-element comparison of the first object
#' provided in `...` with every other object in `...` and returns `TRUE` if all
#' comparisons are equal within a given tolerance and `FALSE` otherwise.
#'
#' @param ... (`numeric`)\cr vectors to be compared.
#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
#' judging equality.
#'
#' @note If there are any missing or infinite values in `...`, this function
#'   returns `FALSE`, regardless of the values of other elements in `...`.
#'
#' @note If elements in `...` are not all of the same length, `FALSE` is returned.
#'
#' @return `TRUE` if all element-by-element differences are less than `tolerance`
#' in magnitude, `FALSE` otherwise.
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_equal(1:2, 1:2) # TRUE
#' check_equal(1:2, 2:3) # "Not all equal"
#' check_equal(Inf, Inf) # "Not all equal"
#' check_equal(0.01, 0.02) # "Not all equal"
#' check_equal(0.01, 0.02, tol = 0.05) # TRUE
#' check_equal(1, c(1, 1)) # "Not all equal"
check_equal <- function(..., tol = sqrt(.Machine$double.eps)) {
  dot_args <- list(...)

  sapply(dot_args, assert_numeric)

  tmp <- sapply(dot_args, length)
  if (min(tmp) != max(tmp)) {
    return("Not all of same length")
  }
  if (any(sapply(dot_args, is.na))) {
    return("Some entries NA")
  }
  if (any(sapply(dot_args, is.infinite))) {
    return("Not all entries finite")
  }
  if (!all(sapply(dot_args, test_numeric))) {
    return("Not all numeric")
  }

  all_ok <- test_true(
    all(
      sapply(
        2:length(dot_args),
        function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol
      )
    )
  )
  if (all_ok) {
    return(TRUE)
  }
  "Not all equal"
}

#' Assert That All Arguments Are Equal
#'
#' @description `r lifecycle::badge("experimental")`
#' Elements of `...` must be numeric vectors or scalars.
#'
#' This function performs an element-by-element comparison of the first object
#' provided in `...` with every other object in `...` and throws an error if they
#' are not.
#'
#' @param ... (`numeric`)\cr vectors to be compared
#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
#' judging equality
#'
#' @note If there are any missing or infinite values in `...`, this function
#'   throws an error, regardless of the values of other elements in `...`.
#'
#' @note If elements in `...` are not all of the same length, an error is thrown.
#'
#' @return `list(...)`, invisibly.
#' @seealso [`assertions`] for more details.
#' @inheritParams checkmate::assert_numeric
#'
#' @export
#' @rdname check_equal
#' @examples
#' assert_equal(1:2, 1:2) # no error
#' assert_equal(0.01, 0.02, tol = 0.05) # no error
# nolint start
assert_equal <- function(
  ...,
  tol = sqrt(.Machine$double.eps),
  .var.name = vname(x),
  add = NULL
) {
  # assert_equal <- makeAssertionFunction(check_equal) fails with error "Error
  # in `checkmate::makeAssertion(..., res, .var.name, add)`: unused argument
  # (add)", possibly because of the use of ... in check_equal.
  res <- check_equal(..., tol = tol)
  makeAssertion(list(...), res, .var.name, add)
}
# nolint end

# assert_probabilities ----

#' Check if an argument is a probability vector
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if every element in a given numerical vector or matrix represents a
#' probability, that is a number within (0, 1) interval, that can optionally be
#' closed at any side.
#'
#' @note If there are any missing or non-finite values in `x`, this function
#'   returns `FALSE`, regardless of the values of other elements in `x`.
#'
#' @param x (`numeric`)\cr vector or matrix with numerical values to check.
#' @param bounds_closed (`logical`)\cr should bounds be closed? This can be a
#'   scalar or vector of length two. If it is a scalar, then its value applies
#'   equally to lower bound \eqn{0} and upper bound \eqn{1}. If this is a vector
#'   with two flags, the first flag corresponds to the lower bound \eqn{0}
#'   only, and the second to the upper bound \eqn{1} only.
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' x <- c(0, 0.2, 0.1, 0.3, 1)
#' check_probabilities(x)
#' check_probabilities(x, bounds_closed = FALSE)
#' check_probabilities(x, bounds_closed = c(FALSE, TRUE))
check_probabilities <- function(
  x,
  bounds_closed = TRUE,
  len = NULL,
  unique = FALSE,
  sorted = FALSE
) {
  assert_numeric(x)
  assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_number(len, null.ok = TRUE)
  assert_flag(sorted)

  result <- check_numeric(
    x,
    finite = TRUE,
    any.missing = FALSE,
    len = len,
    unique = unique,
    sorted = sorted
  )

  if (isTRUE(result)) {
    in_bounds <- all(h_in_range(
      x,
      range = c(0L, 1L),
      bounds_closed = bounds_closed
    ))
    if (!in_bounds) {
      result <- paste(
        "Probability must be within",
        ifelse(bounds_closed[1], "[0,", "(0,"),
        ifelse(tail(bounds_closed, 1), "1]", "1)"),
        "bounds but it is not"
      )
    }
  }

  result
}

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
assert_probabilities <- makeAssertionFunction(check_probabilities)

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
test_probabilities <- makeTestFunction(check_probabilities)

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
expect_probabilities <- makeExpectationFunction(check_probabilities)

# assert_probability ----

#' Check if an argument is a single probability value
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if a given value represents a probability, that is a number within
#' (0, 1) interval, that can optionally be closed at any side.
#'
#' @param x (`number`)\cr a single value to check.
#' @inheritParams check_probabilities
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_probability(0.5)
#' check_probability(0, bounds_closed = FALSE)
#' check_probability(0, bounds_closed = c(FALSE, TRUE))
check_probability <- function(x, bounds_closed = TRUE) {
  check_probabilities(x = x, bounds_closed = bounds_closed, len = 1)
}

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
assert_probability <- makeAssertionFunction(check_probability)

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
test_probability <- makeTestFunction(check_probability)

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
expect_probability <- makeExpectationFunction(check_probability)

# assert_probability_range ----

#' Check if an argument is a probability range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if a given numerical interval represents a probability range, that is
#' a sub-interval of (0, 1) interval, that can optionally be closed at any side.
#'
#' @param x (`number`)\cr an interval to check.
#' @inheritParams check_probabilities
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' x <- c(0, 0.2)
#' check_probability_range(x)
#' check_probability_range(rev(x))
#' check_probability_range(x, bounds_closed = FALSE)
#' check_probability_range(x, bounds_closed = c(FALSE, TRUE))
check_probability_range <- function(x, bounds_closed = TRUE) {
  check_probabilities(
    x = x,
    bounds_closed = bounds_closed,
    len = 2,
    sorted = TRUE
  )
}

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
assert_probability_range <- makeAssertionFunction(check_probability_range)

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
test_probability_range <- makeTestFunction(check_probability_range)

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
expect_probability_range <- makeExpectationFunction(check_probability_range)

# assert_length ----

#' Check if vectors are of compatible lengths
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Two vectors are of compatible size if and only if: \cr
#' 1. At least one vector has size 1 \cr
#' 2. or both vectors are of the same size. \cr
#'
#' @param x (`any`)\cr the first vector, any object for which [length()]
#'   function is defined.
#' @param len (`count`)\cr the length of the second vector.
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_length(1:5, 1)
#' check_length(1:5, 6)
#' check_length(1:5, 5)
#' check_length(10, 1)
#' check_length(10, 9)
check_length <- function(x, len) {
  x_len <- length(x)
  assert_true(x_len >= 1L)
  assert_count(len)

  if (x_len == 1L || len == 1L || x_len == len) {
    TRUE
  } else {
    paste(
      "x is of length",
      x_len,
      "which is not allowed; the allowed lengths are: 1 or",
      len,
      collapse = ""
    )
  }
}

#' @rdname check_length
#' @inheritParams check_length
#' @export
assert_length <- makeAssertionFunction(check_length)

#' @rdname check_length
#' @inheritParams check_length
#' @export
test_length <- makeTestFunction(check_length)

# assert_range ----

#' Check that an argument is a numerical range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' An argument `x` is a numerical range if and only if (all conditions must be met):
#' 1. Is an object of type: `integer` or `double`.
#' 2. Is a vector or length two such that the value of the first number is not
#' less than the second number. Equalness is allowed if and only if `unique` flag
#' is set to `TRUE`.
#' 3. Lower bound of the interval is greater than or equal to `lower` and
#' upper bound of the interval is less than or equal to `upper`.
#' 4. It contains only finite (given that `finite` is `TRUE`) and non-missing values.
#'
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_range(c(1, 5))
#' check_range(c(-5, 1))
#' check_range(c(4, 1))
#' check_range(c(1, 1))
#' check_range(c(1, 1), unique = FALSE)
#' check_range(1:3)
check_range <- function(
  x,
  lower = -Inf,
  upper = Inf,
  finite = FALSE,
  unique = TRUE
) {
  assert_number(lower)
  assert_number(upper)
  assert_flag(finite)
  assert_flag(unique)

  result <- check_numeric(
    x,
    lower = lower,
    upper = upper,
    finite = finite,
    any.missing = FALSE,
    len = 2,
    unique = unique,
    sorted = TRUE
  )

  if (!isTRUE(result)) {
    result <- paste("x must be a valid numerical range.", result)
  }
  result
}

#' @rdname check_range
#' @inheritParams check_range
#' @export
assert_range <- makeAssertionFunction(check_range)

#' @rdname check_range
#' @inheritParams check_range
#' @export
test_range <- makeTestFunction(check_range)

#' @rdname check_range
#' @inheritParams check_range
#' @export
expect_range <- makeExpectationFunction(check_range)

# assert_format ----

#' Check that an argument is a valid format specification
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_format("%5.2f")
check_format <- function(x, len = NULL, min.len = NULL, max.len = NULL) {
  assert_number(len, lower = 1, null.ok = TRUE)
  assert_number(min.len, lower = 1, null.ok = TRUE)
  assert_number(max.len, lower = 1, null.ok = TRUE)

  result <- check_character(
    x,
    len = len,
    min.len = min.len,
    max.len = max.len,
    any.missing = FALSE,
    # https://stackoverflow.com/questions/446285/validate-sprintf-format-from-input-field-with-regex
    pattern = "%(?:\\d+\\$)?[+-]?(?:[ 0]|'.{1})?-?\\d*(?:\\.\\d+)?[bcdeEufFgGosxX]",
  )

  if (!isTRUE(result)) {
    result <- paste("x must be a valid format specifier.", result)
  }
  result
}

#' @rdname check_format
#' @inheritParams check_format
#' @export
assert_format <- makeAssertionFunction(check_format)

#' @rdname check_format
#' @inheritParams check_format
#' @export
test_format <- makeTestFunction(check_format)

#' @rdname check_format
#' @inheritParams check_format
#' @export
expect_format <- makeExpectationFunction(check_format)

#' Apply a Function to Subsets of Data Frame.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' `dapply` splits the data `df` into the subsets defined by `f`,
#' and applies function `FUN` to each of the subset.
#' All the results are row-binded and returned as `data.frame` object.
#'
#' @param df (`data frame`)\cr data set to be divided into groups.
#' @param f (`factor` or `formula` or `list`)\cr a factor in the sense that
#'   `as.factor(f)` defines the grouping, or a `list` of such factors in which
#'   case their interaction is used for the grouping. `f` can also be a formula
#'   of the form `~ g1 + ... + gk` to split by the interaction of the variables
#'   `g1, ..., gk`. This parameter is passed directly into [split()] function.
#' @param FUN (`function`)\cr the function to be applied to each subset of `df`
#'   defined by `f`.
#' @param ... parameters passed to [lapply()], which is used when applying a
#'   function `FUN` over groups defined by `f`.
#'
#' @return The [`data.frame`] object with results from `FUN`.
#'
#' @export
#' @example examples/utils-dapply.R
#'
dapply <- function(df, f, FUN, ...) {
  assert_data_frame(df)

  list_df <- split(df, f = f)
  list_df <- lapply(list_df, FUN, ...)
  df2 <- do.call(rbind, list_df)
  rownames(df2) <- NULL
  df2
}

#' @include helpers.R
#' @include helpers_jags.R
#' @include Model-validity.R
#' @include ModelParams-class.R
#' @include CrmPackClass-class.R
NULL

# GeneralModel-class ----

#' `GeneralModel`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`GeneralModel`] is a general model class, from which all other specific
#' model-like classes inherit.
#'
#' @note The `datamodel` must obey the convention that the data input is
#'   called exactly in the same way as in the corresponding data class.
#'   All prior distributions for parameters should be contained in the
#'   model function `priormodel`. The background is that this can
#'   be used to simulate from the prior distribution, before obtaining any data.
#'
#' @slot datamodel (`function`)\cr a function representing the `JAGS` data model
#'   specification.
#' @slot priormodel (`function`)\cr a function representing the `JAGS` prior
#'   specification.
#' @slot modelspecs (`function`)\cr a function computing the list of the data
#'   model and prior model specifications that are required to be specified
#'   completely (e.g. prior parameters, reference dose, etc.), based on the data
#'   slots that are required as arguments of this function.
#'   Apart of data arguments, this function can be specified with one additional
#'   (optional) argument `from_prior` of type `logical` and length one. This
#'   `from_prior` flag can be used to differentiate the output of the `modelspecs`,
#'   as its value is taken directly from the `from_prior` argument of the `mcmc`
#'   method that invokes `modelspecs` function. That is, when `from_prior` is
#'   `TRUE`, then only `priormodel` JAGS model is used (`datamodel` is not used)
#'   by the `mcmc`, and hence `modelspecs` function should return all the parameters
#'   that are required by the `priormodel` only. If the value of `from_prior` is
#'   `FALSE`, then both JAGS models `datamodel` and `priormodel` are used in the
#'   MCMC sampler, and hence `modelspecs` function should return all the parameters
#'   required by both `datamodel` and `priormodel`.
#' @slot init (`function`)\cr a function computing the list of starting values
#'   for parameters required to be initialized in the MCMC sampler, based on the
#'   data slots that are required as arguments of this function.
#' @slot datanames (`character`)\cr the names of all data slots that are used
#'   by `datamodel` JAGS function. No other names should be specified here.
#' @slot datanames_prior (`character`)\cr the names of all data slots that are
#'   used by `priormodel` JAGS function. No other names should be specified here.
#' @slot sample (`character`)\cr names of all parameters from which you would
#'   like to save the MCMC samples.
#'
#' @seealso [`ModelPseudo`].
#'
#' @aliases GeneralModel
#' @export
#'
.GeneralModel <- setClass(
  Class = "GeneralModel",
  slots = c(
    datamodel = "function",
    priormodel = "function",
    modelspecs = "function",
    init = "function",
    datanames = "character",
    datanames_prior = "character",
    sample = "character"
  ),
  prototype = prototype(
    datamodel = I,
    priormodel = I,
    init = function() {
      list()
    }
  ),
  contains = "CrmPackClass",
  validity = v_general_model
)

## default constructor ----

#' @rdname GeneralModel-class
#' @note Typically, end users will not use the `.DefaultGeneralModel()` function.
#' @export
.DefaultGeneralModel <- function() {
  stop(paste0(
    "Class GeneralModel should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}


# ModelLogNormal ----

## class ----

#' `ModelLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelLogNormal`] is the class for a model with a reference dose and bivariate
#' normal prior on the model parameters `alpha0` and natural logarithm of `alpha1`,
#' i.e.: \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov),}. Transformations other
#' than `log`, e.g. identity, can be specified too in `priormodel` slot.
#' The parameter `alpha1` has a log-normal distribution by default to ensure
#' positivity of `alpha1` which further guarantees `exp(alpha1) > 1`.
#' The slots of this class contain the mean vector, the covariance and
#' precision matrices of the bivariate normal distribution, as well as the
#' reference dose. Note that the precision matrix is an inverse of the
#' covariance matrix in the `JAGS`.
#' All ("normal") model specific classes inherit from this class.
#'
#' @slot params (`ModelParamsNormal`)\cr bivariate normal prior parameters.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#'
#' @seealso [`ModelParamsNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormal`], [`ProbitLogNormalRel`].
#'
#' @aliases ModelLogNormal
#' @export
#'
.ModelLogNormal <- setClass(
  Class = "ModelLogNormal",
  contains = "GeneralModel",
  slots = c(
    params = "ModelParamsNormal",
    ref_dose = "positive_number"
  )
)

## constructor ----

#' @rdname ModelLogNormal-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*} (strictly positive
#'   number).
#'
#' @export
#'
ModelLogNormal <- function(mean, cov, ref_dose = 1) {
  params <- ModelParamsNormal(mean, cov)
  .ModelLogNormal(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- exp(theta[2])
    },
    modelspecs = function(from_prior) {
      ms <- list(mean = params@mean, prec = params@prec)
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}

## default constructor ----

#' @rdname ModelLogNormal-class
#' @note Typically, end users will not use the `.DefaultModelLogNormal()` function.
#' @export
.DefaultModelLogNormal <- function() {
  ModelLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
  )
}

# LogisticNormal ----

## class ----

#' `LogisticNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormal`] is the class for the usual logistic regression model with
#' a bivariate normal prior on the intercept and slope.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, alpha1) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticLogNormal`], [`LogisticLogNormalSub`],
#'   [`ProbitLogNormal`], [`ProbitLogNormalRel`], [`LogisticNormalMixture`].
#'
#' @aliases LogisticNormal
#' @export
#'
.LogisticNormal <- setClass(
  Class = "LogisticNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticNormal.R
#'
LogisticNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .LogisticNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- theta[2]
    }
  )
}

## default constructor ----

#' @rdname LogisticNormal-class
#' @note Typically, end users will not use the `.DefaultLogisticNormal()` function.
#' @export
.DefaultLogisticNormal <- function() {
  LogisticNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
  )
}


# LogisticLogNormal ----

## class ----

#' `LogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormal`] is the class for the usual logistic regression model
#' with a bivariate normal prior on the intercept and log slope.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormalSub`],
#'   [`ProbitLogNormal`], [`ProbitLogNormalRel`], [`LogisticLogNormalMixture`],
#'   [`DALogisticLogNormal`].
#'
#' @aliases LogisticLogNormal
#' @export
#'
.LogisticLogNormal <- setClass(
  Class = "LogisticLogNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticLogNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticLogNormal.R
#'
LogisticLogNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .LogisticLogNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname LogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormal()` function.
#' @export
.DefaultLogisticLogNormal <- function() {
  LogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# LogisticLogNormalSub ----

## class ----

#' `LogisticLogNormalSub`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormalSub`] is the class for a standard logistic model with
#' bivariate (log) normal prior with subtractive dose standardization.
#'
#' @details The covariate is the dose \eqn{x} minus the reference dose \eqn{x*},
#'   i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * (x - x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @slot params (`ModelParamsNormal`)\cr bivariate normal prior parameters.
#' @slot ref_dose (`number`)\cr the reference dose \eqn{x*}.
#'
#' @seealso [`LogisticNormal`], [`LogisticLogNormal`], [`ProbitLogNormal`],
#'   [`ProbitLogNormalRel`].
#'
#' @aliases LogisticLogNormalSub
#' @export
#'
.LogisticLogNormalSub <- setClass(
  Class = "LogisticLogNormalSub",
  slots = c(
    params = "ModelParamsNormal",
    ref_dose = "numeric"
  ),
  contains = "GeneralModel"
)

## constructor ----

#' @rdname LogisticLogNormalSub-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}.
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalSub.R
#'
LogisticLogNormalSub <- function(mean, cov, ref_dose = 0) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalSub(
    params = params,
    ref_dose = ref_dose,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * (x[i] - ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- exp(theta[2])
    },
    modelspecs = function(from_prior) {
      ms <- list(mean = params@mean, prec = params@prec)
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, -20))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}


## default constructor ----

#' @rdname LogisticLogNormalSub-class
#' @note Typically, end-users will not use the `.DefaultLogisticLogNormalSub()` function.
#' @export
.DefaultLogisticLogNormalSub <- function() {
  LogisticLogNormalSub(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# ProbitLogNormal ----

## class ----

#' `ProbitLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ProbitLogNormal`] is the class for probit regression model with a
#' bivariate normal prior on the intercept and log slope.
#'
#' @details The covariate is the natural logarithm of dose \eqn{x} divided by a
#'   reference dose \eqn{x*}, i.e.:
#'   \deqn{probit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @note The model used in the [`DualEndpoint`] classes is an extension of this model:
#'   `DualEndpoint` supports both `ProbitNormal` (which is not implemented yet) and
#'   `ProbitLogNormal` models through its `use_log_dose` slot.
#'   `ProbitLogNormal` has no such flag, so always uses `log(x/x*)`as a covariate in
#'   its model. Therefore this class can be used to check the prior assumptions on the
#'   dose-toxicity model, even when sampling from the prior distribution of the dual
#'   endpoint model is not possible, when `use_log_dose = TRUE` is used.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormalRel`].
#'
#' @aliases ProbitLogNormalLogDose
#' @export
#'
.ProbitLogNormal <- setClass(
  Class = "ProbitLogNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname ProbitLogNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-ProbitLogNormal.R
#'
ProbitLogNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .ProbitLogNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        probit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname ProbitLogNormal-class
#' @note Typically, end users will not use the `.DefaultProbitLogNormal()` function.
#' @export
.DefaultProbitLogNormal <- function() {
  ProbitLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 7.2
  )
}

# ProbitLogNormalRel ----

## class ----

#' `ProbitLogNormalRel`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ProbitLogNormalRel`] is the class for probit regression model with a bivariate
#' normal prior on the intercept and log slope.
#'
#' @details The covariate is the dose \eqn{x} divided by a reference dose \eqn{x*},
#'   i.e.:
#'   \deqn{probit[p(x)] = alpha0 + alpha1 * x/x*,}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @note This model is also used in the [`DualEndpoint`] classes, so this class
#'   can be used to check the prior assumptions on the dose-toxicity model, even
#'   when sampling from the prior distribution of the dual endpoint model is not
#'   possible.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormal`].
#'
#' @aliases ProbitLogNormalRel
#' @export
#'
.ProbitLogNormalRel <- setClass(
  Class = "ProbitLogNormalRel",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname ProbitLogNormalRel-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-ProbitLogNormalRel.R
#'
ProbitLogNormalRel <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .ProbitLogNormalRel(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        probit(p[i]) <- alpha0 + alpha1 * (x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname ProbitLogNormalRel-class
#' @note Typically, end users will not use the `.DefaultProbitLogNormalRel()` function.
#' @export
.DefaultProbitLogNormalRel <- function() {
  ProbitLogNormalRel(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
  )
}

# LogisticLogNormalGrouped ----

## class ----

#' `LogisticLogNormalGrouped`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticLogNormalGrouped`] is the class for a logistic regression model
#'  for both the mono and the combo arms of the simultaneous dose escalation
#'  design.
#'
#' @details The continuous covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*} as in [`LogisticLogNormal`]. In addition,
#'   \eqn{I_c} is a binary indicator covariate which is 1 for the combo arm and 0 for the mono arm.
#'   The model is then defined as:
#'   \deqn{logit[p(x)] = (alpha0 + I_c * delta0) + (alpha1 + I_c * delta1) * log(x / x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x},
#'   and `delta0` and `delta1` are the differences in the combo arm compared to the mono intercept
#'   and slope parameters `alpha0` and `alpha1`.
#'   The prior is defined as \deqn{(alpha0, log(delta0), log(alpha1), log(delta1)) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticLogNormal`].
#'
#' @aliases LogisticLogNormalGrouped
#' @export
#'
.LogisticLogNormalGrouped <- setClass(
  Class = "LogisticLogNormalGrouped",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticLogNormalGrouped-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalGrouped.R
#'
LogisticLogNormalGrouped <- function(mean, cov, ref_dose = 1) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalGrouped(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      delta0 <- exp(theta[2])
      alpha1 <- exp(theta[3])
      delta1 <- exp(theta[4])
    },
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- (alpha0 + is_combo[i] * delta0) +
          (alpha1 + is_combo[i] * delta1) * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    modelspecs = function(group, from_prior) {
      ms <- list(
        mean = params@mean,
        prec = params@prec
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
        ms$is_combo <- as.integer(group == "combo")
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1, 1, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "delta0", "alpha1", "delta1")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalGrouped-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormalGrouped()` function.
#' @export
.DefaultLogisticLogNormalGrouped <- function() {
  LogisticLogNormalGrouped(
    mean = rep(0, 4),
    cov = diag(rep(1, 4)),
  )
}

# LogisticKadane ----

## class ----

#' `LogisticKadane`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticKadane`] is the class for the logistic model in the parametrization
#' of \insertCite{KadaneDickeyWinklerSmithPeters1980;textual}{crmPack}.
#'
#' @details Let `rho0 = p(xmin)` be the probability of a DLT at the minimum dose
#'   `xmin`, and let `gamma` be the dose with target toxicity probability `theta`,
#'   i.e. \eqn{p(gamma) = theta}. Then it can easily be shown that the logistic
#'   regression model has intercept
#'   \deqn{[gamma * logit(rho0) - xmin * logit(theta)] / [gamma - xmin]}
#'   and slope
#'   \deqn{[logit(theta) - logit(rho0)] / [gamma - xmin].}
#'
#'   The priors are \deqn{gamma ~ Unif(xmin, xmax).} and
#'   \deqn{rho0 ~ Unif(0, theta).}
#'
#' @note The slots of this class, required for creating the model, are the target
#'   toxicity, as well as the minimum and maximum of the dose range. Note that
#'   these can be different from the minimum and maximum of the dose grid in the
#'   data later on.
#'
#' @slot theta (`proportion`)\cr the target toxicity probability.
#' @slot xmin (`number`)\cr the minimum of the dose range.
#' @slot xmax (`number`)\cr the maximum of the dose range.
#'
#' @seealso [`ModelLogNormal`]
#'
#' @aliases LogisticKadane
#' @export
#' @references
#'   \insertAllCited{}
#'
.LogisticKadane <- setClass(
  Class = "LogisticKadane",
  contains = "GeneralModel",
  slots = c(
    theta = "numeric",
    xmin = "numeric",
    xmax = "numeric"
  ),
  prototype = prototype(
    theta = 0.3,
    xmin = 0.1,
    xmax = 1
  ),
  validity = v_model_logistic_kadane
)

## constructor ----

#' @rdname LogisticKadane-class
#'
#' @param theta (`proportion`)\cr the target toxicity probability.
#' @param xmin (`number`)\cr the minimum of the dose range.
#' @param xmax (`number`)\cr the maximum of the dose range.
#'
#' @export
#' @example examples/Model-class-LogisticKadane.R
#'
LogisticKadane <- function(theta, xmin, xmax) {
  .LogisticKadane(
    theta = theta,
    xmin = xmin,
    xmax = xmax,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- (1 / (gamma - xmin)) *
          (gamma *
            logit(rho0) -
            xmin * logit(theta) +
            x[i] * (logit(theta) - logit(rho0)))
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      rho0 ~ dunif(0, theta)
      gamma ~ dunif(xmin, xmax)
    },
    modelspecs = function() {
      list(theta = theta, xmin = xmin, xmax = xmax)
    },
    init = function() {
      list(rho0 = theta / 10, gamma = (xmax - xmin) / 2)
    },
    datanames = c("nObs", "y", "x"),
    sample = c("rho0", "gamma")
  )
}

## default constructor ----

#' @rdname LogisticKadane-class
#' @note Typically, end-users will not use the `.DefaultLogisticKadane()` function.
#' @export
.DefaultLogisticKadane <- function() {
  LogisticKadane(theta = 0.33, xmin = 1, xmax = 200)
}


# LogisticKadaneBetaGamma ----

## class ----

#' `LogisticKadaneBetaGamma`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticKadaneBetaGamma`] is the class for the logistic model in the parametrization
#' of \insertCite{KadaneDickeyWinklerSmithPeters1980;textual}{crmPack},
#' using a beta and a gamma distribution as the model priors.
#'
#' @details Let `rho0 = p(xmin)` be the probability of a DLT at the minimum dose
#'   `xmin`, and let `gamma` be the dose with target toxicity probability `theta`,
#'   i.e. \eqn{p(gamma) = theta}. Then it can easily be shown that the logistic
#'   regression model has intercept
#'   \deqn{[gamma * logit(rho0) - xmin * logit(theta)] / [gamma - xmin]}
#'   and slope
#'   \deqn{[logit(theta) - logit(rho0)] / [gamma - xmin].}
#'
#'   The prior for `gamma`, is \deqn{gamma ~ Gamma(shape, rate).}.
#'   The prior for `rho0 = p(xmin)`, is \deqn{rho0 ~ Beta(alpha, beta).}
#'
#' @note The slots of this class, required for creating the model, are the same
#'   as in the `LogisticKadane` class. In addition, the shape parameters of the
#'   Beta prior distribution of `rho0` and the shape and rate parameters of the
#'   Gamma prior distribution of `gamma`, are required for creating the prior model.
#'
#' @slot theta (`proportion`)\cr the target toxicity probability.
#' @slot xmin (`number`)\cr the minimum of the dose range.
#' @slot xmax (`number`)\cr the maximum of the dose range.
#' @slot alpha (`number`)\cr the first shape parameter of the Beta prior distribution
#'   of `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @slot beta (`number`)\cr the second shape parameter of the Beta prior distribution
#'   of `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @slot shape (`number`)\cr the shape parameter of the Gamma prior distribution
#'   of `gamma` the dose with target toxicity probability `theta`.
#' @slot rate (`number`)\cr the rate parameter of the Gamma prior distribution
#'   of `gamma` the dose with target toxicity probability `theta`.
#'
#' @seealso [`ModelLogNormal`], [`LogisticKadane`].
#'
#' @aliases LogisticKadaneBetaGamma
#' @export
#' @references
#'   \insertAllCited{}
#'
.LogisticKadaneBetaGamma <- setClass(
  Class = "LogisticKadaneBetaGamma",
  contains = "LogisticKadane",
  slots = c(
    alpha = "numeric",
    beta = "numeric",
    shape = "numeric",
    rate = "numeric"
  ),
  prototype = prototype(
    theta = 0.3,
    xmin = 0.1,
    xmax = 1,
    alpha = 1,
    beta = 0.5,
    shape = 1.2,
    rate = 2.5
  ),
  validity = v_model_logistic_kadane_beta_gamma
)

## constructor ----

#' @rdname LogisticKadaneBetaGamma-class
#'
#' @inheritParams LogisticKadane
#'
#' @param alpha (`number`)\cr the first shape parameter of the Beta prior distribution
#'   `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @param beta (`number`)\cr the second shape parameter of the Beta prior distribution
#'   `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @param shape (`number`)\cr the shape parameter of the Gamma prior distribution
#'   `gamma` the dose with target toxicity probability `theta`.
#' @param rate (`number`)\cr the rate parameter of the Gamma prior distribution
#'   `gamma` the dose with target toxicity probability `theta`.
#'
#' @export
#' @example examples/Model-class-LogisticKadaneBetaGamma.R
#'
LogisticKadaneBetaGamma <- function(
  theta,
  xmin,
  xmax,
  alpha,
  beta,
  shape,
  rate
) {
  model_lk <- LogisticKadane(theta = theta, xmin = xmin, xmax = xmax)
  .LogisticKadaneBetaGamma(
    model_lk,
    alpha = alpha,
    beta = beta,
    shape = shape,
    rate = rate,
    priormodel = function() {
      rho0 ~ dbeta(alpha, beta)
      gamma ~ dgamma(shape, rate)
      lowestdose <- xmin
      highestdose <- xmax
      DLTtarget <- theta
    },
    modelspecs = function() {
      list(
        theta = theta,
        xmin = xmin,
        xmax = xmax,
        alpha = alpha,
        beta = beta,
        shape = shape,
        rate = rate
      )
    }
  )
}

## default constructor ----

#' @rdname LogisticKadaneBetaGamma-class
#' @note Typically, end users will not use the `.Default()` function.
#' @export
.DefaultLogisticKadaneBetaGamma <- function() {
  LogisticKadaneBetaGamma(
    theta = 0.3,
    xmin = 0,
    xmax = 7,
    alpha = 1,
    beta = 19,
    shape = 0.5625,
    rate = 0.125
  )
}

# LogisticNormalMixture ----

## class ----

#' `LogisticNormalMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormalMixture`] is the class for standard logistic regression model
#' with a mixture of two bivariate normal priors on the intercept and slope parameters.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior
#'   \deqn{(alpha0, alpha1) ~ w * Normal(mean1, cov1) + (1 - w) * Normal(mean2, cov2).}
#'   The weight w for the first component is assigned a beta prior `B(a, b)`.
#'
#' @note The weight of the two normal priors is a model parameter, hence it is a
#'   flexible mixture. This type of prior is often used with a mixture of a minimal
#'   informative and an informative component, in order to make the CRM more robust
#'   to data deviations from the informative component.
#'
#' @slot comp1 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the first component.
#' @slot comp2 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the second component.
#' @slot weightpar (`numeric`)\cr the beta parameters for the weight of the
#'   first component. It must a be a named vector of length 2 with names `a` and
#'   `b` and with strictly positive values.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#'
#' @seealso [`ModelParamsNormal`], [`ModelLogNormal`],
#'   [`LogisticNormalFixedMixture`], [`LogisticLogNormalMixture`].
#'
#' @aliases LogisticNormalMixture
#' @export
#'
.LogisticNormalMixture <- setClass(
  Class = "LogisticNormalMixture",
  contains = "GeneralModel",
  slots = c(
    comp1 = "ModelParamsNormal",
    comp2 = "ModelParamsNormal",
    weightpar = "numeric",
    ref_dose = "numeric"
  ),
  prototype = prototype(
    comp1 = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
    comp2 = ModelParamsNormal(mean = c(-1, 1), cov = diag(2)),
    weightpar = c(a = 1, b = 1),
    ref_dose = 1
  ),
  validity = v_model_logistic_normal_mix
)

## constructor ----

#' @rdname LogisticNormalMixture-class
#'
#' @param comp1 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the first component. See [`ModelParamsNormal`] for more details.
#' @param comp2 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the second component. See [`ModelParamsNormal`] for more details.
#' @param weightpar (`numeric`)\cr the beta parameters for the weight of the
#'   first component. It must a be a named vector of length 2 with names `a` and
#'   `b` and with strictly positive values.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}
#'   (strictly positive number).
#'
#' @export
#' @example examples/Model-class-LogisticNormalMixture.R
#'
LogisticNormalMixture <- function(comp1, comp2, weightpar, ref_dose) {
  assert_number(ref_dose)

  .LogisticNormalMixture(
    comp1 = comp1,
    comp2 = comp2,
    weightpar = weightpar,
    ref_dose = ref_dose,
    datamodel = function() {
      # The logistic likelihood - the same as for non-mixture case.
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      w ~ dbeta(weightpar[1], weightpar[2])
      wc <- 1 - w
      comp0 ~ dbern(wc)
      comp <- comp0 + 1
      # Conditional on the component index "comp", which is  1 or 2.
      # comp = 1 with probability "w" and comp = 2 with probability "1 - w".
      theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
      alpha0 <- theta[1]
      alpha1 <- theta[2]
    },
    modelspecs = function(from_prior) {
      ms <- list(
        mean = cbind(comp1@mean, comp2@mean),
        prec = array(data = c(comp1@prec, comp2@prec), dim = c(2, 2, 2)),
        weightpar = weightpar
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1", "w")
  )
}

## default constructor ----

#' @rdname LogisticNormalMixture-class
#' @note Typically, end-users will not use the `.DefaultLogisticNormalMixture()` function.
#' @export
.DefaultLogisticNormalMixture <- function() {
  # nolint
  LogisticNormalMixture(
    comp1 = ModelParamsNormal(
      mean = c(-0.85, 1),
      cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
    ),
    comp2 = ModelParamsNormal(
      mean = c(1, 1.5),
      cov = matrix(c(1.2, -0.45, -0.45, 0.6), nrow = 2)
    ),
    weightpar = c(a = 1, b = 1),
    ref_dose = 50
  )
}

# LogisticNormalFixedMixture ----

## class ----

#' `LogisticNormalFixedMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormalFixedMixture`] is the class for standard logistic regression
#' model with fixed mixture of multiple bivariate (log) normal priors on the
#' intercept and slope parameters. The weights of the normal priors are fixed,
#' hence no additional model parameters are introduced. This type of prior is
#' often used to better approximate a given posterior distribution, or when the
#' information is given in terms of a mixture.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided
#'   by the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior
#'   \deqn{(alpha0, alpha1) ~ w1 * Normal(mean1, cov1) + ... + wK * Normal(meanK, covK),}
#'   if a normal prior is used and
#'   \deqn{(alpha0, log(alpha1)) ~ w1 * Normal(mean1, cov1) + ... + wK * Normal(meanK, covK),}
#'   if a log normal prior is used.
#'   The weights \eqn{w1, ..., wK} of the components are fixed and sum to 1.
#'
#'   The slots of this class comprise a list with components parameters. Every
#'   single component contains the mean vector and the covariance matrix of
#'   bivariate normal distributions. Remaining slots are the weights of the
#'   components as well as the reference dose. Moreover, a special indicator
#'   slot specifies whether a log normal prior is used.
#'
#' @slot components (`list`)\cr the specifications of the mixture components,
#'   a list with [`ModelParamsNormal`] objects for each bivariate (log) normal
#'   prior.
#' @slot weights (`numeric`)\cr the weights of the components; these must be
#'   positive and must sum to 1.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#' @slot log_normal (`flag`)\cr should a log normal prior be used, such
#'   that the mean vectors and covariance matrices are valid for the intercept
#'   and log slope?
#'
#' @seealso [`ModelParamsNormal`], [`ModelLogNormal`],
#'   [`LogisticNormalMixture`], [`LogisticLogNormalMixture`].
#'
#' @aliases LogisticNormalFixedMixture
#' @export
#'
.LogisticNormalFixedMixture <- setClass(
  Class = "LogisticNormalFixedMixture",
  contains = "GeneralModel",
  slots = c(
    components = "list",
    weights = "numeric",
    ref_dose = "numeric",
    log_normal = "logical"
  ),
  prototype = prototype(
    components = list(
      comp1 = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
      comp2 = ModelParamsNormal(mean = c(-1, 1), cov = diag(2))
    ),
    weights = c(0.5, 0.5),
    ref_dose = 1,
    log_normal = FALSE
  ),
  validity = v_model_logistic_normal_fixed_mix
)

## constructor ----

#' @rdname LogisticNormalFixedMixture-class
#'
#' @param components (`list`)\cr the specifications of the mixture components,
#'   a list with [`ModelParamsNormal`] objects for each bivariate (log) normal
#'   prior.
#' @param weights (`numeric`)\cr the weights of the components; these must be
#'   positive and will be normalized to sum to 1.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}
#'   (strictly positive number).
#' @param log_normal (`flag`)\cr should a log normal prior be specified, such
#'   that the mean vectors and covariance matrices are valid for the intercept
#'   and log slope?
#'
#' @export
#' @example examples/Model-class-LogisticNormalFixedMixture.R
#'
LogisticNormalFixedMixture <- function(
  components,
  weights,
  ref_dose,
  log_normal = FALSE
) {
  assert_numeric(weights)
  assert_number(ref_dose)
  assert_flag(log_normal)

  # Normalize weights to sum to 1.
  weights <- weights / sum(weights)

  .LogisticNormalFixedMixture(
    components = components,
    weights = weights,
    ref_dose = positive_number(ref_dose),
    log_normal = log_normal,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = if (log_normal) {
      function() {
        comp ~ dcat(weights)
        theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
        alpha0 <- theta[1]
        alpha1 <- exp(theta[2])
      }
    } else {
      function() {
        comp ~ dcat(weights)
        theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
        alpha0 <- theta[1]
        alpha1 <- theta[2]
      }
    },
    modelspecs = function(from_prior) {
      ms <- list(
        weights = weights,
        mean = do.call(
          cbind,
          lapply(components, h_slots, "mean", simplify = TRUE)
        ),
        prec = array(
          do.call(c, lapply(components, h_slots, "prec", simplify = TRUE)),
          dim = c(2, 2, length(components))
        )
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}

## default constructor ----

#' @rdname LogisticNormalFixedMixture-class
#' @note Typically, end-users will not use the `.DefaultLogisticNormalFixedMixture()`
#' function.
#' @export
.DefaultLogisticNormalFixedMixture <- function() {
  # nolint
  LogisticNormalFixedMixture(
    components = list(
      comp1 = ModelParamsNormal(
        mean = c(-0.85, 1),
        cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
      ),
      comp2 = ModelParamsNormal(
        mean = c(1, 1.5),
        cov = matrix(c(1.2, -0.45, -0.45, 0.6), nrow = 2)
      )
    ),
    weights = c(0.3, 0.7),
    ref_dose = 50
  )
}

# LogisticLogNormalMixture ----

## class ----

#' `LogisticLogNormalMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormalMixture`] is the class for standard logistic model with
#' online mixture of two bivariate log normal priors.
#'
#' @details This model can be used when data is arising online from the informative
#'   component of the prior, at the same time with the data of the trial of
#'   main interest. Formally, this is achieved by assuming that the probability
#'   of a DLT at dose \eqn{x} is given by
#'   \deqn{p(x) = \pi * p1(x) + (1 - \pi) * p2(x)}
#'   where \eqn{\pi} is the probability for the model \eqn{p(x)} being the same
#'   as the model \eqn{p1(x)}, which is the informative component of the prior.
#'   From this model data arises in parallel: at doses `xshare`, DLT information
#'   `yshare` is observed, in total `nObsshare` data points (see [`DataMixture`]).
#'   On the other hand, \eqn{1 - \pi}, is the probability of a separate model
#'   \eqn{p2(x)}. Both components have the same log normal prior distribution,
#'   which can be specified by the user, and which is inherited from the
#'   [`LogisticLogNormal`] class.
#'
#' @slot share_weight (`proportion`)\cr the prior weight for the share component
#'   \eqn{p_{1}(x)}.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`],
#'   [`LogisticNormalFixedMixture`].
#'
#' @aliases LogisticLogNormalMixture
#' @export
#'
.LogisticLogNormalMixture <- setClass(
  Class = "LogisticLogNormalMixture",
  contains = "LogisticLogNormal",
  slots = c(
    share_weight = "numeric"
  ),
  prototype = prototype(
    share_weight = 0.1
  ),
  validity = v_model_logistic_log_normal_mix
)

## constructor ----

#' @rdname LogisticLogNormalMixture-class
#'
#' @inheritParams ModelLogNormal
#' @param share_weight (`proportion`)\cr the prior weight for the share component.
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalMixture.R
#'
LogisticLogNormalMixture <- function(mean, cov, ref_dose, share_weight) {
  assert_number(ref_dose)

  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalMixture(
    params = params,
    ref_dose = positive_number(ref_dose),
    share_weight = share_weight,
    datamodel = function() {
      for (i in 1:nObs) {
        # comp gives the component: non-informative (1) or share (2) the two components.
        stand_log_dose[i] <- log(x[i] / ref_dose)
        logit(p[i]) <- alpha0[comp] + alpha1[comp] * stand_log_dose[i]
        y[i] ~ dbern(p[i])
      }
      for (j in 1:nObsshare) {
        stand_log_dose_share[j] <- log(xshare[j] / ref_dose)
        logit(pshare[j]) <- alpha0[2] + alpha1[2] * stand_log_dose_share[j]
        yshare[j] ~ dbern(pshare[j])
      }
    },
    priormodel = function() {
      for (k in 1:2) {
        theta[k, 1:2] ~ dmnorm(mean, prec)
        alpha0[k] <- theta[k, 1]
        alpha1[k] <- exp(theta[k, 2])
      }
      # The component indicator.
      comp ~ dcat(cat_probs)
    },
    modelspecs = function(from_prior) {
      ms <- list(
        cat_probs = c(1 - share_weight, share_weight),
        mean = params@mean,
        prec = params@prec
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = matrix(c(0, 0, 1, 1), nrow = 2))
    },
    datanames = c("nObs", "y", "x", "nObsshare", "yshare", "xshare"),
    sample = c("alpha0", "alpha1", "comp")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalMixture-class
#' @note Typically, end users will not use the `.DefaultLogNormalMixture()` function.
#' @export
.DefaultLogisticLogNormalMixture <- function() {
  # nolint
  LogisticLogNormalMixture(
    share_weight = 0.1,
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# DualEndpoint ----

## class ----

#' `DualEndpoint`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpoint`] is the general class for the dual endpoint model.
#'
#' @details The idea of the dual-endpoint models is to model not only the
#'   dose-toxicity relationship, but also to model, at the same time, the
#'   relationship of a PD biomarker with the dose. The sub-classes of this class
#'   define how the dose-biomarker relationship is parametrized. This class here
#'   shall contain all the common features to reduce duplicate code.
#'   (This class however, must not be virtual as we need to create objects
#'   of it during the construction of subclass objects.)
#'
#'   The dose-toxicity relationship is modeled with probit regression model
#'   \deqn{probit[p(x)] = betaZ1 + betaZ2 * x/x*,}
#'   or
#'   \deqn{probit[p(x)] = betaZ1 + betaZ2 * log(x/x*),}
#'   in case when the option `use_log_dose` is `TRUE`.
#'   Here, \eqn{p(x)} is the probability of observing a DLT for a given
#'   dose \eqn{x} and \eqn{x*} is the reference dose.
#'   The prior \deqn{(betaZ1, log(betaZ2)) ~ Normal(mean, cov).}
#'
#'   For the biomarker response \eqn{w} at a dose \eqn{x}, we assume
#'   \deqn{w(x) ~ Normal(f(x), sigma2W),}
#'   where \eqn{f(x)} is a function of the dose \eqn{x}, which is further
#'   specified in sub-classes. The biomarker variance \eqn{sigma2W} can be fixed
#'   or assigned an Inverse-Gamma prior distribution; see the details below under
#'   slot `sigma2W`.
#'
#'   Finally, the two endpoints \eqn{y} (the binary DLT variable) and \eqn{w}
#'   (the biomarker) can be correlated, by assuming a correlation of level
#'   \eqn{rho} between the underlying continuous latent toxicity variable \eqn{z}
#'   and the biomarker \eqn{w}. Again, this correlation can be fixed or assigned
#'   a prior distribution from the scaled Beta family; see the details below
#'   under slot `rho`.
#'
#'   Please see the example vignette by typing `crmPackExample()` for a full example.
#'
#' @slot betaZ_params (`ModelParamsNormal`)\cr for the probit toxicity model, it
#'   contains the prior mean, covariance matrix and precision matrix which is
#'   internally calculated as an inverse of the covariance matrix.
#' @slot ref_dose (`positive_number`)\cr for the probit toxicity model, the
#'   reference dose.
#' @slot use_log_dose (`flag`)\cr for the probit toxicity model, whether a log
#'   transformation of the (standardized) dose should be used?
#' @slot sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @slot rho (`numeric`)\cr either a fixed value for the correlation
#'   (between `-1` and `1`), or a named vector with two elements named `a` and `b`
#'   for the Beta prior on the transformation `kappa = (rho + 1) / 2`, which is
#'   in `(0, 1)`. For example, `a = 1, b = 1` leads to a uniform prior on `rho`.
#' @slot use_fixed (`logical`)\cr indicates whether a fixed value for `sigma2W`
#'   or `rho` (for each parameter separately) is used or not. This slot is
#'   needed for internal purposes and must not be touched by the user.
#'
#' @seealso [`DualEndpointRW`], [`DualEndpointBeta`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpoint
#' @export
#'
.DualEndpoint <- setClass(
  Class = "DualEndpoint",
  slots = c(
    betaZ_params = "ModelParamsNormal",
    ref_dose = "positive_number",
    use_log_dose = "logical",
    sigma2W = "numeric",
    rho = "numeric",
    use_fixed = "logical"
  ),
  prototype = prototype(
    betaZ_params = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
    ref_dose = positive_number(1),
    use_log_dose = FALSE,
    sigma2W = 1,
    rho = 0,
    use_fixed = c(sigma2W = TRUE, rho = TRUE)
  ),
  contains = "GeneralModel",
  validity = v_model_dual_endpoint
)

## constructor ----

#' @rdname DualEndpoint-class
#'
#' @param mean (`numeric`)\cr for the probit toxicity model, the prior mean vector.
#' @param cov (`matrix`)\cr for the probit toxicity model, the prior covariance
#'   matrix. The precision matrix is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr for the probit toxicity model, the reference
#'   dose \eqn{x*} (strictly positive number).
#' @param use_log_dose (`flag`)\cr for the probit toxicity model, whether a log
#'   transformation of the (standardized) dose should be used?
#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @param rho (`numeric`)\cr either a fixed value for the correlation
#'   (between `-1` and `1`), or a named vector with two elements named `a` and `b`
#'   for the Beta prior on the transformation `kappa = (rho + 1) / 2`, which is
#'   in `(0, 1)`. For example, `a = 1, b = 1` leads to a uniform prior on `rho`.
#'
#' @export
#'
DualEndpoint <- function(
  mean,
  cov,
  ref_dose = 1,
  use_log_dose = FALSE,
  sigma2W,
  rho
) {
  assert_number(ref_dose)
  assert_numeric(sigma2W, min.len = 1, max.len = 2)
  assert_numeric(rho, min.len = 1, max.len = 2)

  use_fixed <- c(
    sigma2W = test_number(sigma2W),
    rho = test_number(rho)
  )
  beta_z_params <- ModelParamsNormal(mean, cov)

  datamodel <- function() {
    for (i in 1:nObs) {
      # The toxicity model.
      stand_dose_temp[i] <- x[i] / ref_dose
      stand_dose[i] <- ifelse(
        use_log_dose,
        log(stand_dose_temp[i]),
        stand_dose_temp[i]
      )
      meanZ[i] <- betaZ[1] + betaZ[2] * stand_dose[i]
      z[i] ~ dnorm(meanZ[i], 1)
      y[i] ~ dinterval(z[i], 0)

      # The conditional biomarker model; betaW defined in subclasses!
      condMeanW[i] <- betaW[xLevel[i]] + rho / sqrt(precW) * (z[i] - meanZ[i])
      w[i] ~ dnorm(condMeanW[i], condPrecW)
    }
  }
  priormodel <- function() {
    # Priors for betaW defined in subclasses!
    theta ~ dmnorm(betaZ_mean, betaZ_prec)
    betaZ[1] <- theta[1]
    betaZ[2] <- exp(theta[2])
    # Conditional precision for biomarker.
    # Code for `precW` and `rho` will be added by
    # `h_model_dual_endpoint_sigma2w()`, `h_model_dual_endpoint_rho()` helpers, below.
    condPrecW <- precW / (1 - pow(rho, 2))
  }
  modelspecs_prior <- list(
    betaZ_mean = beta_z_params@mean,
    betaZ_prec = beta_z_params@prec
  )

  comp <- list(
    priormodel = priormodel,
    modelspecs = modelspecs_prior,
    init = NULL,
    sample = "betaZ"
  )

  # Update model components with regard to biomarker regression variance.
  comp <- h_model_dual_endpoint_sigma2w(
    use_fixed["sigma2W"],
    sigma2W = sigma2W,
    comp = comp
  )

  # Update model components with regard to DLT and biomarker correlation.
  comp <- h_model_dual_endpoint_rho(
    use_fixed["rho"],
    rho = rho,
    comp = comp
  )

  .DualEndpoint(
    betaZ_params = beta_z_params,
    ref_dose = positive_number(ref_dose),
    use_log_dose = use_log_dose,
    sigma2W = sigma2W,
    rho = rho,
    use_fixed = use_fixed,
    datamodel = datamodel,
    priormodel = comp$priormodel,
    modelspecs = function(from_prior) {
      if (!from_prior) {
        comp$modelspecs$ref_dose <- ref_dose
        comp$modelspecs$use_log_dose <- use_log_dose
      }
      comp$modelspecs
    },
    init = function(y) {
      c(comp$init, list(z = ifelse(y == 0, -1, 1), theta = c(0, 1)))
    },
    datanames = c("nObs", "w", "x", "xLevel", "y"),
    sample = comp$sample
  )
}

## default constructor ----

#' @rdname DualEndpoint-class
#' @note Typically, end users will not use the `.DefaultDualEndpoint()` function.
#' @export
.DefaultDualEndpoint <- function() {
  stop(paste0(
    "Class DualEndpoint cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# DualEndpointRW ----

## class ----

#' `DualEndpointRW`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointRW`] is the class for the dual endpoint model with random walk
#' prior for biomarker.
#'
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a non-parametric random walk of first
#'   or second order. That means, for the first order random walk we assume
#'   \deqn{betaW_i - betaW_i-1 ~ Normal(0, (x_i - x_i-1) * sigma2betaW),}
#'   where \eqn{betaW_i = f(x_i)} is the biomarker mean at the \eqn{i}-th dose
#'   gridpoint \eqn{x_i}.
#'   For the second order random walk, the second-order differences instead of
#'   the first-order differences of the biomarker means follow the normal distribution
#'   with \eqn{0} mean and \eqn{2 * (x_i - x_i-2) * sigma2betaW} variance.
#'
#'   The variance parameter \eqn{sigma2betaW} is important because it steers the
#'   smoothness of the function \eqn{f(x)}, i.e.: if it is large, then \eqn{f(x)}
#'   will be very wiggly; if it is small, then \eqn{f(x)} will be smooth.
#'   This parameter can either be a fixed value or assigned an inverse gamma prior
#'   distribution.
#'
#' @note Non-equidistant dose grids can be used now, because the difference
#'   \eqn{x_i - x_i-1} is included in the modelling assumption above.
#'   Please note that due to impropriety of the random walk prior distributions,
#'   it is not possible to produce MCMC samples with empty data objects (i.e.,
#'   sample from the prior). This is not a bug, but a theoretical feature of this
#'   model.
#'
#' @slot sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @slot rw1 (`flag`)\cr for specifying the random walk prior on the biomarker
#'   level. When `TRUE`, random walk of first order is used. Otherwise, the
#'   random walk of second order is used.
#'
#' @seealso [`DualEndpoint`], [`DualEndpointBeta`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpointRW
#' @export
#'
.DualEndpointRW <- setClass(
  Class = "DualEndpointRW",
  slots = c(
    sigma2betaW = "numeric",
    rw1 = "logical"
  ),
  prototype = prototype(
    sigma2betaW = 1,
    rw1 = TRUE,
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      sigma2betaW = TRUE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_rw
)

## constructor ----

#' @rdname DualEndpointRW-class
#'
#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @param rw1 (`flag`)\cr for specifying the random walk prior on the biomarker
#'   level. When `TRUE`, random walk of first order is used. Otherwise, the
#'   random walk of second order is used.
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointRW.R
#'
DualEndpointRW <- function(sigma2betaW, rw1 = TRUE, ...) {
  assert_numeric(sigma2betaW, min.len = 1, max.len = 2)
  assert_flag(rw1)

  start <- DualEndpoint(...)
  start@use_fixed["sigma2betaW"] <- length(sigma2betaW) == 1L

  priormodel <- if (rw1) {
    function() {
      # The 1st order differences.
      # Essentially dflat(), which is not available in JAGS.
      betaW[1] ~ dnorm(0, 0.000001)
      for (i in 2:nGrid) {
        delta[i - 1] ~ dnorm(0, precBetaW / (doseGrid[i] - doseGrid[i - 1]))
        betaW[i] <- betaW[i - 1] + delta[i - 1]
      }
    }
  } else {
    function() {
      # The 2nd order differences.
      delta[1] ~ dnorm(0, 0.000001)
      betaW[1] ~ dnorm(0, 0.000001)
      betaW[2] <- betaW[1] + delta[1]
      for (i in 3:nGrid) {
        # delta2: differences of the differences of betaW follow normal dist.
        delta2[i - 2] ~
          dnorm(0, 2 * precBetaW / (doseGrid[i] - doseGrid[i - 2]))
        delta[i - 1] <- delta[i - 2] + delta2[i - 2]
        betaW[i] <- betaW[i - 1] + delta[i - 1]
      }
    }
  }
  start@priormodel <- h_jags_join_models(start@priormodel, priormodel)
  start@datanames_prior <- c("nGrid", "doseGrid")
  start@sample <- c(start@sample, "betaW", "delta")

  # Update model components with regard to biomarker regression variance.
  start <- h_model_dual_endpoint_sigma2betaw(
    start@use_fixed["sigma2betaW"],
    sigma2betaW = sigma2betaW,
    de = start
  )

  .DualEndpointRW(
    start,
    sigma2betaW = sigma2betaW,
    rw1 = rw1
  )
}

## default constructor ----

#' @rdname DualEndpointRW-class
#' @note Typically, end users will not use the `.DefaultDualEndpointRW()` function.
#' @export
.DefaultDualEndpointRW <- function() {
  DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    sigma2betaW = 0.01,
    rw1 = TRUE
  )
}

# DualEndpointBeta ----

## class ----

#' `DualEndpointBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointBeta`] is the class for the dual endpoint model with beta
#' function for dose-biomarker relationship.
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a parametric, rescaled beta density
#'   function:
#'   \deqn{f(x) = E0 + (Emax - E0) * Beta(delta1, delta2) * (x/x*)^{delta1} * (1 - x/x*)^{delta2},}
#'   where \eqn{x*} is the maximum dose (end of the dose range to be considered),
#'   \eqn{delta1} and \eqn{delta2} are the two beta function parameters, and
#'   \eqn{E0}, \eqn{Emax} are the minimum and maximum levels, respectively.
#'   For ease of interpretation, we use the parametrization based on \eqn{delta1}
#'   and the mode, where
#'   \deqn{mode = delta1 / (delta1 + delta2),}
#'   so that multiplying this by \eqn{x*} gives the mode on the dose grid.
#'
#'   All parameters can currently be assigned uniform distributions or be fixed
#'   in advance. Note that \code{E0} and \code{Emax} can have negative values or
#'   uniform distributions reaching into negative range, while \code{delta1} and
#'   \code{mode} must be positive or have uniform distributions in the positive
#'   range.
#'
#' @slot E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @slot Emax (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot delta1 (`numeric`)\cr either a fixed positive number or the two
#'   parameters of the uniform distribution, that can take only positive values.
#' @slot mode (`numeric`)\cr either a fixed positive number or the two
#'   parameters of the uniform distribution, that can take only positive values.
#' @slot ref_dose_beta (`positive_number`)\cr the reference dose \eqn{x*} (note
#'   that this is different from the `ref_dose` in the inherited [`DualEndpoint`]
#'   model).
#'
#' @seealso [`DualEndpoint`], [`DualEndpointRW`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpointBeta
#' @export
#'
.DualEndpointBeta <- setClass(
  Class = "DualEndpointBeta",
  slots = c(
    E0 = "numeric",
    Emax = "numeric",
    delta1 = "numeric",
    mode = "numeric",
    ref_dose_beta = "positive_number"
  ),
  prototype = prototype(
    E0 = c(0, 100),
    Emax = c(0, 500),
    delta1 = c(0, 5),
    mode = c(1, 15),
    ref_dose_beta = positive_number(1),
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      E0 = FALSE,
      Emax = FALSE,
      delta1 = FALSE,
      mode = FALSE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_beta
)

## constructor ----

#' @rdname DualEndpointBeta-class
#'
#' @param E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param Emax (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param delta1 (`numeric`)\cr either a fixed positive number or the two parameters
#'   of the uniform distribution, that can take only positive values.
#' @param mode (`numeric`)\cr either a fixed positive number or the two parameters
#'   of the uniform distribution, that can take only positive values.
#' @param ref_dose_beta (`number`)\cr the reference dose \eqn{x*} (strictly
#'   positive number). Note that this is different from the `ref_dose` in the
#'   inherited [`DualEndpoint`] model).
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointBeta.R
#'
DualEndpointBeta <- function(E0, Emax, delta1, mode, ref_dose_beta = 1, ...) {
  assert_numeric(E0, min.len = 1, max.len = 2)
  assert_numeric(Emax, min.len = 1, max.len = 2)
  assert_numeric(delta1, min.len = 1, max.len = 2)
  assert_numeric(mode, min.len = 1, max.len = 2)
  assert_number(ref_dose_beta)

  start <- DualEndpoint(...)

  ms <- start@modelspecs
  start@modelspecs <- function(from_prior) {
    c(list(ref_dose_beta = ref_dose_beta), ms(from_prior))
  }
  start@datanames_prior <- c("nGrid", "doseGrid")
  start@sample <- c(start@sample, "betaW")

  start <- h_model_dual_endpoint_beta(
    param = E0,
    param_name = "E0",
    priormodel = function() {
      E0 ~ dunif(E0_low, E0_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = Emax,
    param_name = "Emax",
    priormodel = function() {
      Emax ~ dunif(Emax_low, Emax_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = delta1,
    param_name = "delta1",
    priormodel = function() {
      delta1 ~ dunif(delta1_low, delta1_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = mode,
    param_name = "mode",
    priormodel = function() {
      mode ~ dunif(mode_low, mode_high)
    },
    de = start
  )

  start@priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      # delta2 <- delta1 * (1 - (mode/ref_dose_beta)) / (mode/ref_dose_beta) # nolint
      delta2 <- delta1 * (ref_dose_beta / mode - 1)
      # betafun <- (delta1 + delta2)^(delta1 + delta2) * delta1^(- delta1) * delta2^(- delta2) # nolint
      betafun <- (1 + delta2 / delta1)^delta1 * (delta1 / delta2 + 1)^delta2
      for (i in 1:nGrid) {
        stand_dose_beta[i] <- doseGrid[i] / ref_dose_beta
        betaW[i] <- E0 +
          (Emax - E0) *
            betafun *
            stand_dose_beta[i]^delta1 *
            (1 - stand_dose_beta[i])^delta2
      }
    }
  )

  .DualEndpointBeta(
    start,
    E0 = E0,
    Emax = Emax,
    delta1 = delta1,
    mode = mode,
    ref_dose_beta = positive_number(ref_dose_beta)
  )
}

## default constructor ----

#' @rdname DualEndpointBeta-class
#' @note Typically, end users will not use the `.DefaultDualEndpointBeta()` function.
#' @export
.DefaultDualEndpointBeta <- function() {
  DualEndpointBeta(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    ref_dose = 10,
    use_log_dose = TRUE,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    E0 = c(0, 100),
    Emax = c(0, 500),
    delta1 = c(0, 5),
    mode = c(1, 15),
    ref_dose_beta = 1000
  )
}

# DualEndpointEmax ----

## class ----

#' `DualEndpointEmax`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointEmax`] is the class for the dual endpoint model with `Emax`
#' function for dose-biomarker relationship.
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a parametric `Emax` function:
#'   \deqn{f(x) = E0 + [(Emax - E0) * (x/x*)]/[ED50 + (x/x*)],}
#'   where \eqn{x*} is a reference dose, \eqn{E0} and \eqn{Emax} are the minimum
#'   and maximum levels for the biomarker, and \eqn{ED50} is the dose achieving
#'   half of the maximum effect \eqn{0.5 * Emax}.
#'   All parameters can currently be assigned uniform distributions or be fixed.
#'
#' @slot E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @slot Emax (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot ED50 (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot ref_dose_emax (`positive_number`)\cr the reference dose \eqn{x*} (note
#'   that this is different from the `ref_dose` in the inherited [`DualEndpoint`]
#'   model).
#'
#' @seealso [`DualEndpoint`], [`DualEndpointRW`], [`DualEndpointBeta`].
#'
#' @aliases DualEndpointEmax
#' @export
#'
.DualEndpointEmax <- setClass(
  Class = "DualEndpointEmax",
  slots = c(
    E0 = "numeric",
    Emax = "numeric",
    ED50 = "numeric",
    ref_dose_emax = "numeric"
  ),
  prototype = prototype(
    E0 = c(0, 100),
    Emax = c(0, 500),
    ED50 = c(0, 500),
    ref_dose_emax = positive_number(1),
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      E0 = FALSE,
      Emax = FALSE,
      ED50 = FALSE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_emax
)

## constructor ----

#' @rdname DualEndpointEmax-class
#'
#' @param E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param Emax (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param ED50 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param ref_dose_emax (`number`)\cr the reference dose \eqn{x*} (strictly
#'   positive number). Note that this is different from the `ref_dose` in the
#'   inherited [`DualEndpoint`] model).
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointEmax.R
#'
DualEndpointEmax <- function(E0, Emax, ED50, ref_dose_emax = 1, ...) {
  assert_numeric(E0, min.len = 1, max.len = 2)
  assert_numeric(Emax, min.len = 1, max.len = 2)
  assert_numeric(ED50, min.len = 1, max.len = 2)
  assert_number(ref_dose_emax)

  start <- DualEndpoint(...)

  start@sample <- c(start@sample, "betaW")
  start@datanames_prior <- c("nGrid", "doseGrid")
  ms <- start@modelspecs
  start@modelspecs <- function(from_prior) {
    c(list(ref_dose_emax = ref_dose_emax), ms(from_prior))
  }

  start <- h_model_dual_endpoint_beta(
    param = E0,
    param_name = "E0",
    priormodel = function() {
      E0 ~ dunif(E0_low, E0_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = Emax,
    param_name = "Emax",
    priormodel = function() {
      Emax ~ dunif(Emax_low, Emax_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = ED50,
    param_name = "ED50",
    priormodel = function() {
      ED50 ~ dunif(ED50_low, ED50_high)
    },
    de = start
  )

  start@priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      for (i in 1:nGrid) {
        stand_dose_emax[i] <- doseGrid[i] / ref_dose_emax
        betaW[i] <- E0 +
          (Emax - E0) * stand_dose_emax[i] / (ED50 + stand_dose_emax[i])
      }
    }
  )

  .DualEndpointEmax(
    start,
    E0 = E0,
    Emax = Emax,
    ED50 = ED50,
    ref_dose_emax = positive_number(ref_dose_emax)
  )
}

## default constructor ----

#' @rdname DualEndpointEmax-class
#' @note Typically, end users will not use the `.DefaultDualEndpointEmax()` function.
#' @export
.DefaultDualEndpointEmax <- function() {
  DualEndpointEmax(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    E0 = c(0, 100),
    Emax = c(0, 500),
    ED50 = c(10, 200),
    ref_dose_emax = 1000
  )
}

# ModelPseudo ----

## class ----

#' `ModelPseudo`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelPseudo`] is the parent class for models that express their prior in
#' the form of pseudo data (as if there is some data before the trial starts).
#'
#' @seealso [`GeneralModel`].
#'
#' @aliases ModelPseudo
#' @export
#'
.ModelPseudo <- setClass(
  Class = "ModelPseudo",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname ModelPseudo-class
#' @note Typically, end users will not use the `.DefaultModelPseudo()` function.
#' @export
.DefaultModelPseudo <- function() {
  stop(paste0(
    "Class ModelPseudo should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# ModelTox ----

## class ----

#' `ModelTox`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelTox`] is the parent class for DLE (dose-limiting events) models using
#' pseudo data prior. It is dedicated for DLE models or toxicity models that
#' have their prior specified in the form of pseudo data (as if there is some
#' data before the trial starts).
#'
#' The `data` must obey the convention of the [`Data`] class. This refers to any
#' observed DLE responses (`y` in [`Data`]), the dose levels (`x` in [`Data`])
#' at which these responses are observed, all dose levels considered in the
#' study (`doseGrid` in [`Data`]), and finally other specifications in [`Data`]
#' class that can be used to generate prior or posterior modal estimates or
#' samples estimates for model parameter(s).
#' If no responses are observed, at least `doseGrid` has to be specified
#' in `data` for which prior modal estimates or samples can be obtained for
#' model parameters based on the specified pseudo data.
#'
#' @slot data (`Data`)\cr observed data that is used to obtain model parameters
#'   estimates or samples (see details above).
#'
#' @seealso [`ModelEff`].
#'
#' @aliases ModelTox
#' @export
#'
.ModelTox <- setClass(
  Class = "ModelTox",
  slots = c(
    data = "Data"
  ),
  contains = "ModelPseudo"
)

## default constructor ----

#' @rdname ModelTox-class
#' @note Typically, end users will not use the `.DefaultModelTox()` function.
#' @export
.DefaultModelTox <- function() {
  stop(paste0(
    "Class ModelTox should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# ModelEff ----

## class ----

#' `ModelEff`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelEff`] is the parent class for efficacy models using pseudo data prior.
#' It is dedicated all efficacy models that have their prior specified in the
#' form of pseudo data (as if there is some data before the trial starts).
#'
#' The `data` must obey the convention of the [`DataDual`] class. This refers to
#' any observed efficacy/biomarker responses (`w` in [`DataDual`]), the dose
#' levels at which these responses are observed (`x` in [`DataDual`]), all dose
#' levels considered in the study (`doseGrid` in [`DataDual`]), and finally
#' other specifications in [`DataDual`] class that can be used to generate prior
#' or posterior modal estimates or samples estimates for model parameter(s).
#' If no responses are observed, at least `doseGrid` has to be specified
#' in `data` for which prior modal estimates or samples can be obtained for
#' model parameters based on the specified pseudo data.
#'
#' @slot data (`DataDual`)\cr observed data that is used to obtain model
#'   parameters estimates or samples (see details above).
#'
#' @seealso [`ModelTox`].
#'
#' @aliases ModelEff
#' @export
#'
.ModelEff <- setClass(
  Class = "ModelEff",
  slots = c(
    data = "DataDual"
  ),
  contains = "ModelPseudo"
)

## default constructor ----

#' @rdname ModelEff-class
#' @note Typically, end users will not use the `.DefaultModelEff()` function.
#' @export
.DefaultModelEff <- function() {
  stop(paste0(
    "Class ModelEff should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# LogisticIndepBeta ----

## class ----

#' `LogisticIndepBeta`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticIndepBeta`] is the class for the two-parameters logistic regression
#' dose-limiting events (DLE) model with prior expressed in form of pseudo data.
#' This model describes the relationship between the binary DLE responses
#' and the dose levels. More specifically, it represents the relationship of the
#' probabilities of the occurrence of a DLE for corresponding dose levels in log
#' scale. This model is specified as
#' \deqn{p(x) = exp(phi1 + phi2 * log(x)) / (1 + exp(phi1 + phi2 * log(x)))}
#' where \eqn{p(x)} is the probability of the occurrence of a DLE at dose \eqn{x}.
#' The two parameters of this model are the intercept \eqn{phi1} and the slope
#' \eqn{phi2}. The `LogisticIndepBeta` inherits all slots from [`ModelTox`] class.
#'
#' In the context of pseudo data, the following three arguments are used,
#' `binDLE`, `DLEdose` and `DLEweights`. The `DLEdose` represents fixed dose
#' levels at which the pseudo DLE responses `binDLE` are observed. `DLEweights`
#' represents total number of subjects treated per each dose level in `DLEdose`.
#' The `binDLE` represents the number of subjects observed with DLE per each
#' dose level in `DLEdose`. Hence, all these three vectors must be of the same
#' length and the order of the elements in any of the vectors `binDLE`,
#' `DLEdose` and `DLEweights` must be kept, so that an element of a given vector
#' corresponds to the elements of the remaining two vectors (see the example for
#' more insight).
#' Finally, since at least two DLE pseudo responses are needed to
#' obtain prior modal estimates (same as the maximum likelihood estimates) for
#' the model parameters, the `binDLE`, `DLEdose` and `DLEweights` must all be
#' vectors of at least length 2.
#'
#' @details The pseudo data can be interpreted as if we obtain some observations
#'   before the trial starts. It can be used to express our prior, i.e. the
#'   initial beliefs for the model parameters. The pseudo data is expressed in
#'   the following way. First, fix at least two dose levels, then ask for experts'
#'   opinion on how many subjects are to be treated at each of these dose levels
#'   and on the number of subjects observed with a DLE. At each dose level, the
#'   number of subjects observed with a DLE, divided by the total number of
#'   subjects treated, is the probability of the occurrence of a DLE at that
#'   particular dose level. The probabilities of the occurrence of a DLE based
#'   on this pseudo data are independent and they follow Beta distributions.
#'   Therefore, the joint prior probability density function of all these
#'   probabilities can be obtained. Hence, by a change of variable, the joint
#'   prior probability density function of the two parameters in this model can
#'   also be obtained. In addition, a conjugate joint prior density function of
#'   the two parameters in the model is used. For details about the form of all
#'   these joint prior and posterior probability density functions, please refer
#'   to \insertCite{WhiteheadWilliamson1998;textual}{crmPack}.
#'
#' @slot binDLE (`numeric`)\cr a vector of total numbers of DLE responses.
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `DLEdose` and `DLEweights`.
#' @slot DLEdose (`numeric`)\cr a vector of the dose levels corresponding to
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `binDLE` and `DLEweights`.
#' @slot DLEweights (`integer`)\cr total number of subjects treated at each of
#'   the pseudo dose level `DLEdose`.
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `binDLE` and `DLEdose`.
#' @slot phi1 (`number`)\cr  the intercept of the model. This slot is used in
#'   output to display the resulting prior or posterior modal estimate of the
#'   intercept obtained based on the pseudo data and (if any) observed data/responses.
#' @slot phi2 (`number`)\cr  the slope of the model. This slot is used in output
#'   to display the resulting prior or posterior modal estimate of the slope
#'   obtained based on the pseudo data and (if any) the observed data/responses.
#' @slot Pcov (`matrix`)\cr refers to the 2x2 covariance matrix of the intercept
#'   (\eqn{phi1}) and the slope parameters (\eqn{phi2}) of the model.
#'   This is used in output to display the resulting prior and posterior
#'   covariance matrix of \eqn{phi1} and \eqn{phi2} obtained, based on the
#'   pseudo data and (if any) the observed data and responses. This slot is
#'   needed for internal purposes.
#'
#' @aliases LogisticIndepBeta
#' @export
#' @references
#'   \insertAllCited{}
#'
.LogisticIndepBeta <- setClass(
  Class = "LogisticIndepBeta",
  slots = c(
    binDLE = "numeric",
    DLEdose = "numeric",
    DLEweights = "integer",
    phi1 = "numeric",
    phi2 = "numeric",
    Pcov = "matrix"
  ),
  prototype = prototype(
    binDLE = c(0, 0),
    DLEdose = c(1, 1),
    DLEweights = c(1L, 1L)
  ),
  contains = "ModelTox",
  validity = v_model_logistic_indep_beta
)

## constructor ----

#' @rdname LogisticIndepBeta-class
#'
#' @param binDLE (`numeric`)\cr the number of subjects observed with a DLE, the
#'   pseudo DLE responses, depending on dose levels `DLEdose`.
#'   Elements of `binDLE` must correspond to the elements of `DLEdose` and
#'   `DLEweights`.
#' @param DLEdose (`numeric`)\cr dose levels for the pseudo DLE responses.
#'   Elements of `DLEdose` must correspond to the elements of `binDLE` and
#'   `DLEweights`.
#' @param DLEweights (`numeric`)\cr the total number of subjects treated at each
#'   of the dose levels `DLEdose`, pseudo weights.
#'   Elements of `DLEweights` must correspond to the elements of `binDLE` and
#'   `DLEdose`.
#' @param data (`Data`)\cr the input data to update estimates of the model
#'   parameters.
#'
#' @export
#' @example examples/Model-class-LogisticIndepBeta.R
#'
LogisticIndepBeta <- function(binDLE, DLEdose, DLEweights, data) {
  assert_numeric(binDLE)
  assert_numeric(DLEdose)
  assert_integerish(DLEweights, lower = 0, any.missing = FALSE)
  assert_class(data, "Data")

  # Combine pseudo and observed data. It can also happen that data@nObs == 0.
  y <- c(binDLE, data@y)
  x <- c(DLEdose, data@x)
  w <- c(DLEweights, rep(1, data@nObs))

  fit_dle <- suppressWarnings(
    glm(y / w ~ log(x), family = binomial(link = "logit"), weights = w)
  )
  phi1 <- coef(fit_dle)[["(Intercept)"]]
  phi2 <- coef(fit_dle)[["log(x)"]]
  Pcov <- vcov(fit_dle)

  .LogisticIndepBeta(
    binDLE = binDLE,
    DLEdose = DLEdose,
    DLEweights = as.integer(DLEweights),
    phi1 = phi1,
    phi2 = phi2,
    Pcov = Pcov,
    data = data
  )
}

## default constructor ----

#' @rdname LogisticIndepBeta-class
#' @note Typically, end users will not use the `.DefaultLogisticIndepBeta()` function.
#' @export
.DefaultLogisticIndepBeta <- function() {
  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3L, 3L),
    DLEdose = c(25, 300),
    data = Data(doseGrid = seq(25, 300, 25))
  )
}


# Effloglog ----

## class ----

#' `Effloglog`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Effloglog`] is the class for the linear log-log efficacy model using pseudo
#' data prior. It describes the relationship between continuous efficacy
#' responses and corresponding dose levels in log-log scale. This efficacy
#' log-log model is given as
#' \deqn{y_i = theta1 + theta2 * log(log(x_i)) + epsilon_i,}
#' where \eqn{y_i} is the efficacy response for subject \eqn{i}, \eqn{x_i} is
#' the dose level treated for subject \eqn{i} and \eqn{epsilon_i} is the random
#' error term of efficacy model at subject \eqn{i}. The error term
#' \eqn{epsilon_i} is a random variable that follows normal distribution with
#' mean \eqn{0} and variance \eqn{nu^{-1}}, which is assumed to be the
#' same for all subjects.
#' There are three parameters in this model, the intercept \eqn{theta1}, the
#' slope \eqn{theta2} and the precision \eqn{nu} of the efficacy responses, also
#' known as the inverse of the variance of the pseudo efficacy responses. It can
#' be a fixed constant or having a gamma distribution. Therefore, a single scalar
#' value or a vector with two positive numbers values must be specified for `nu`
#' slot. If there are some observed efficacy responses available, in the output,
#' `nu` will display the updated value of the precision or the updated values
#' for the parameters of the gamma distribution.
#' The `Effloglog` inherits all slots from [`ModelEff`] class.
#'
#' @details The prior of this model is specified in form of pseudo data. First,
#'   at least two dose levels are fixed. Then, using e.g. experts' opinion, the
#'   efficacy values that correspond to these dose levels can be obtained,
#'   The `eff` and `eff_dose` arguments represent the prior in form of the pseudo
#'   data. The `eff` represents the pseudo efficacy values. The `eff_dose`
#'   represents the dose levels at which these pseudo efficacy values are
#'   observed. Hence, the positions of the elements specified in `eff` and
#'   `eff_dose` must correspond to each other between these vectors.
#'   Since at least 2 pseudo efficacy values are needed to obtain modal
#'   estimates of the intercept and slope parameters, both `eff` and `eff_dose`
#'   must be vectors of length at least 2.
#'
#'   The joint prior distribution of the intercept \eqn{theta1} and the slope
#'   \eqn{theta2} of this model follows bivariate normal distribution with mean
#'   \eqn{mu} and covariance matrix \eqn{(nu * Q)^{-1}}.
#'   The mean \eqn{mu} is a \eqn{2 x 1} column vector that contains the prior
#'   modal estimates of the intercept and the slope.
#'   Scalar \eqn{nu} is the precision of the pseudo efficacy responses and
#'   \eqn{Q} is the prior or posterior (given that observed, no DLT data is
#'   available) precision matrix.
#'   It is specified as \eqn{Q = X0^T * X0 + X^T * X}, where \eqn{X0} is a
#'   design matrix that is based on pseudo dose levels only, and \eqn{X} is a
#'   design matrix that is based on dose levels corresponding to the no DLT
#'   efficacy responses observed only (if any).
#'   Hence, the \eqn{X0} (or \eqn{X}) will be of size \eqn{r x 2}, if
#'   there are \eqn{r >= 2} pseudo efficacy responses specified (or
#'   if there are \eqn{r} no DLT efficacy responses observed in the `data`).
#'
#' @slot eff (`numeric`)\cr the pseudo efficacy responses. Each element here
#'   must represent responses treated based on one subject.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff_dose`.
#' @slot eff_dose (`numeric`)\cr the pseudo efficacy dose levels at which the
#'   pseudo efficacy responses are observed.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff`.
#' @slot nu (`numeric`)\cr parameter of the prior precision of pseudo efficacy
#'   responses. This is either a fixed value or a named vector with two positive
#'   numbers, the shape (`a`), and the rate (`b`) parameters for the gamma
#'   distribution.
#' @slot use_fixed (`flag`)\cr indicates whether `nu` specified is a fixed value
#'   or a vector with two parameters for gamma distribution. This slot is for
#'   internal purposes only and must not be used by the user.
#' @slot theta1 (`number`)\cr the intercept in this efficacy log-log model. This
#'   slot is used in output to display the resulting prior or posterior modal
#'   estimates obtained based on the pseudo and observed (if any) data.
#' @slot theta2 (`number`)\cr the slope in this efficacy log-log model. This
#'   slot is used in output to display the resulting prior or posterior modal
#'   estimates obtained based on the pseudo and observed (if any) data.
#' @slot Pcov (`matrix`)\cr refers to the \eqn{2 x 2} covariance matrix of the
#'   estimators of the intercept \eqn{theta1} and the slope \eqn{theta2}
#'   parameters in this model.
#'   This is used in output to display the resulting prior and posterior
#'   covariance matrix of \eqn{theta1} and \eqn{theta2} obtained, based on the
#'   pseudo and observed (if any) data. This slot is needed for internal purposes.
#' @slot X (`matrix`)\cr is the design matrix that is based on either the pseudo
#'   dose levels or observed dose levels (without DLT). This is used
#'   in the output to display the design matrix for the pseudo or the observed
#'   efficacy responses.
#' @slot Y (`numeric`)\cr is a vector that either contains the pseudo efficacy
#'   responses or observed efficacy responses (without DLT).
#' @slot mu (`numeric`)\cr a vector of the prior or the posterior modal estimates
#'   of the intercept (\eqn{theta1}) and the slope (\eqn{theta2}).
#'   This slot is used in output to display as the mean of the prior or posterior
#'   bivariate normal distribution for \eqn{theta1} and \eqn{theta2}.
#' @slot Q (`matrix`)\cr is the prior or posterior (given that observed, no DLT
#'   data is available) precision matrix. It is specified as
#'   \eqn{Q = X0^T * X0 + X^T * X}, where \eqn{X0} is a design matrix that is
#'   based on pseudo dose levels only, and \eqn{X} is a design matrix that is
#'   based on dose levels corresponding to the observed, no DLT efficacy values
#'   only (if any).
#' @slot const (`number`)\cr a non-negative number (default to 0), leading to the
#'   model form described above. In general, the model has the form
#'   \eqn{y_i = theta1 + theta2 * log(log(x_i + const)) + epsilon_i}, such that
#'   dose levels greater than \eqn{1 - const} can be considered as described in
#'   \insertCite{YeungWhiteheadReignerBeyerDiackJaki2015;textual}{crmPack}.
#'
#' @aliases Effloglog
#' @export
#' @references
#'   \insertAllCited{}
#'
.Effloglog <- setClass(
  Class = "Effloglog",
  slots = c(
    eff = "numeric",
    eff_dose = "numeric",
    nu = "numeric",
    use_fixed = "logical",
    theta1 = "numeric",
    theta2 = "numeric",
    Pcov = "matrix",
    X = "matrix",
    Y = "numeric",
    mu = "numeric",
    Q = "matrix",
    const = "numeric"
  ),
  prototype = prototype(
    eff = c(0, 0),
    eff_dose = c(1, 1),
    nu = 1 / 0.025,
    use_fixed = TRUE,
    const = 0
  ),
  contains = "ModelEff",
  validity = v_model_eff_log_log
)

## constructor ----

#' @rdname Effloglog-class
#'
#' @param eff (`numeric`)\cr the pseudo efficacy responses.
#'   Elements of `eff` must correspond to the elements of `eff_dose`.
#' @param eff_dose (`numeric`)\cr dose levels that correspond to pseudo efficacy
#'   responses in `eff`.
#' @param nu (`numeric`)\cr the precision (inverse of the variance) of the
#'   efficacy responses. This is either a fixed value or a named vector with two
#'   positive numbers, the shape (`a`), and the rate (`b`) parameters for the
#'   gamma distribution.
#' @param data (`DataDual`)\cr observed data to update estimates of the model
#'   parameters.
#' @param const (`number`)\cr the constant value added to the dose level when
#'   the dose level value is less than or equal to 1 and a special form of the
#'   linear log-log has to be applied
#'   \insertCite{YeungWhiteheadReignerBeyerDiackJaki2015}{crmPack}.
#'
#' @export
#' @example examples/Model-class-Effloglog.R
#'
Effloglog <- function(eff, eff_dose, nu, data, const = 0) {
  assert_numeric(eff)
  assert_numeric(eff_dose, len = length(eff))
  assert_numeric(nu, min.len = 1, max.len = 2)
  assert_class(data, "Data")
  assert_number(const, finite = TRUE)

  use_fixed <- length(nu) == 1L

  eff_dose <- eff_dose + const
  # Get observed efficacy data without DLT (if any).
  eff_obsrv_w_x <- getEff(data, no_dlt = TRUE)
  eff_obsrv <- eff_obsrv_w_x$w_no_dlt
  eff_obsrv_dose <- eff_obsrv_w_x$x_no_dlt + const

  # Fit pseudo and observed (if any) efficacy.
  w <- c(eff, eff_obsrv)
  x <- c(eff_dose, eff_obsrv_dose)
  fit_eff <- suppressWarnings(lm(w ~ log(log(x))))
  X <- model.matrix(fit_eff)
  Y <- w
  mu <- coef(fit_eff) # This is [theta1, theta2]^T est.
  Q <- crossprod(X)
  Pcov <- vcov(fit_eff)

  nobs_no_dlt <- length(eff_obsrv)
  if (nobs_no_dlt > 0L) {
    # Observed data available.
    # Set X, Y to observed data only.
    X <- model.matrix(fit_eff)[-seq_along(eff), ]
    Y <- eff_obsrv

    fit_eff0 <- lm(eff ~ log(log(eff_dose))) # Pseudo only.
    X0 <- model.matrix(fit_eff0)
    mu0 <- coef(fit_eff0)
    Q0 <- crossprod(X0)
    # Note that mu = (Q0 + X^T * X)^{-1} * (Q0 * mu0 + X^T * X * (X^T * X)^{-1} X^T * Y),
    # given that (X^T * X) is invertible and X, Y, mu0, Q0, are specified in this else block.
    if (!use_fixed) {
      nu["a"] <- nu["a"] + (nobs_no_dlt) / 2
      nu["b"] <- nu["b"] +
        (crossprod(Y) + t(mu0) %*% Q0 %*% mu0 - t(mu) %*% Q %*% mu) / 2
    }
  }

  .Effloglog(
    eff = eff,
    eff_dose = eff_dose,
    nu = nu,
    use_fixed = use_fixed,
    theta1 = mu[["(Intercept)"]],
    theta2 = mu[["log(log(x))"]],
    Pcov = Pcov,
    X = X,
    Y = Y,
    mu = as.vector(mu),
    Q = Q,
    const = const,
    data = data
  )
}

## default constructor ----

#' @rdname Effloglog-class
#' @note Typically, end users will not use the `.DefaultEffloglog()` function.
#' @export
.DefaultEffloglog <- function() {
  emptydata <- DataDual(doseGrid = seq(25, 300, 25), placebo = FALSE)

  my_data <- DataDual(
    x = c(25, 50, 50, 75, 100, 100, 225, 300),
    y = c(0, 0, 0, 0, 1, 1, 1, 1),
    w = c(0.31, 0.42, 0.59, 0.45, 0.6, 0.7, 0.6, 0.52),
    doseGrid = emptydata@doseGrid,
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 2, 3, 4, 4, 5, 6))
  )

  Effloglog(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    nu = c(a = 1, b = 0.025),
    data = my_data
  )
}

# EffFlexi ----

## class ----

#' `EffFlexi`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`EffFlexi`] is the class for the efficacy model in flexible form of prior
#' expressed in form of pseudo data. In this class, a flexible form is used to
#' describe the relationship between the efficacy responses and the dose levels
#' and it is specified as
#' \deqn{(W | betaW, sigma2W) ~ Normal(X * betaW, sigma2W * I),}
#' where \eqn{W} is a vector of the efficacy responses, \eqn{betaW} is a column
#' vector of the mean efficacy responses for all dose levels, and \eqn{X} is
#' the design matrix with entries \eqn{I_i,j} that are equal to 1 if subject
#' \eqn{i} is allocated to dose \eqn{j}, and \eqn{0} otherwise. The \eqn{sigma2W}
#' is the variance of the efficacy responses which can be either a fixed number
#' or a number from an inverse gamma distribution.
#' This flexible form aims to capture different shapes of the dose-efficacy
#' curve. In addition, the first (RW1) or second order (RW2) random walk model
#' can be used for smoothing data. That is the random walk model is used to model
#' the first or the second order differences of the mean efficacy responses to
#' its neighboring dose levels of their mean efficacy responses.
#'
#' The RW1 model is given as
#' \deqn{betaW_j - betaW_j-1) ~ Normal(0, sigma2betaW),}
#' and for RW2 as
#' \deqn{betaW_j-2 - 2 * betaW_j-1 + beta_j ~ Normal(0, sigma2betaW),}
#' where \eqn{betaW_j} is the vector of mean efficacy responses at dose j, and
#' the \eqn{sigma2betaW} is the prior variance which can be either a fixed
#' number or a number from an inverse gamma distribution.
#'
#' The `eff` and `eff_dose` are the pseudo efficacy responses and dose levels at
#' which these pseudo efficacy responses are observed. Both, `eff` and `eff_dose`
#' must be vectors of length at least 2. The positions of the elements specified
#' in `eff` and `eff_dose` must correspond to each other between these vectors.
#'
#' @details This model will output the updated value or the updated values of the
#'   parameters of the inverse gamma distributions for \eqn{sigma2W} and
#'   \eqn{sigma2betaW}. The `EffFlexi` inherits all slots from [`ModelEff`] class.
#'
#' @slot eff (`numeric`)\cr the pseudo efficacy responses. Each element here
#'   must represent responses treated based on one subject.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff_dose`.
#' @slot eff_dose (`numeric`)\cr the pseudo efficacy dose levels at which the
#'   pseudo efficacy responses are observed.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff`.
#' @slot sigma2W (`numeric`)\cr the prior variance of the flexible efficacy form.
#'   This is either a fixed value or a named vector with two positive numbers,
#'   the shape (`a`), and the rate (`b`) parameters for the gamma distribution.
#' @slot sigma2betaW (`numeric`)\cr the prior variance of the random walk model
#'   for the mean efficacy responses. This is either a fixed value or a named
#'   vector with two positive numbers, the shape (`a`), and the rate (`b`)
#'   parameters for the gamma distribution.
#' @slot use_fixed (`logical`)\cr indicates whether a fixed value for
#'   `sigma2W` and `sigma2betaW` (for each parameter separately) is used or not.
#'   This slot is needed for internal purposes and must not be touched by the user.
#' @slot rw1 (`flag`)\cr used for smoothing data for this efficacy model. If it
#'   is `TRUE`, the first-order random walk model is used for the mean efficacy
#'   responses. Otherwise, the random walk of second order is used.
#' @slot X (`matrix`)\cr the design matrix for the efficacy responses. It is
#'   based on both the pseudo and the observed efficacy responses.
#' @slot RW (`matrix`)\cr the difference matrix for the random walk model. This
#'   slot is needed for internal purposes and must not be used by the user.
#' @slot RW_rank (`integer`)\cr is the rank of the difference matrix. This
#'   slot is needed for internal purposes and must not be used by the user.
#'
#' @aliases EffFlexi
#' @export
#'
.EffFlexi <- setClass(
  Class = "EffFlexi",
  slots = c(
    eff = "numeric",
    eff_dose = "numeric",
    sigma2W = "numeric",
    sigma2betaW = "numeric",
    use_fixed = "logical",
    rw1 = "logical",
    X = "matrix",
    RW = "matrix",
    RW_rank = "integer"
  ),
  prototype = prototype(
    eff = c(0, 0),
    eff_dose = c(1, 1),
    sigma2W = 0.025,
    sigma2betaW = 1,
    rw1 = TRUE,
    use_fixed = c(sigma2W = TRUE, sigma2betaW = TRUE)
  ),
  contains = "ModelEff",
  validity = v_model_eff_flexi
)

## constructor ----

#' @rdname EffFlexi-class
#'
#' @param eff (`numeric`)\cr the pseudo efficacy responses.
#'   Elements of `eff` must correspond to the elements of `eff_dose`.
#' @param eff_dose (`numeric`)\cr dose levels that correspond to pseudo efficacy
#'   responses in `eff`.
#' @param sigma2W (`numeric`)\cr the prior variance of the efficacy responses.
#'   This is either a fixed value or a named vector with two positive numbers,
#'   the shape (`a`), and the rate (`b`) parameters for the inverse gamma
#'   distribution.
#' @param sigma2betaW (`numeric`)\cr the prior variance of the random walk model
#'   used for smoothing. This is either a fixed value or a named vector with two
#'   positive numbers, the shape (`a`), and the rate (`b`) parameters for the
#'   inverse gamma distribution.
#' @param rw1 (`flag`)\cr used for smoothing data for this efficacy model. If it
#'   is `TRUE`, the first-order random walk model is used for the mean efficacy
#'   responses. Otherwise, the random walk of second order is used.
#' @param data (`DataDual`)\cr observed data to update estimates of the model
#'   parameters.
#'
#' @export
#' @example examples/Model-class-EffFlexi.R
#'
EffFlexi <- function(eff, eff_dose, sigma2W, sigma2betaW, rw1 = TRUE, data) {
  assert_numeric(eff)
  assert_numeric(eff_dose)
  assert_numeric(sigma2W, min.len = 1, max.len = 2)
  assert_numeric(sigma2betaW, min.len = 1, max.len = 2)
  assert_flag(rw1)
  assert_class(data, "DataDual")

  use_fixed <- c(
    sigma2W = test_number(sigma2W),
    sigma2betaW = test_number(sigma2betaW)
  )

  x <- c(eff_dose, getEff(data, no_dlt = TRUE)$x_no_dlt)
  x_level <- match_within_tolerance(x, data@doseGrid)
  X <- model.matrix(~ -1L + factor(x_level, levels = seq_len(data@nGrid)))
  X <- matrix(as.integer(X), ncol = ncol(X)) # To remove some obsolete attributes.

  # Set up the random walk penalty matrix and its rank.
  # D1: difference matrix of order 1.
  D1 <- cbind(0, diag(data@nGrid - 1)) - cbind(diag(data@nGrid - 1), 0)
  if (rw1) {
    # the rank-deficient prior precision for the RW1 prior.
    RW <- crossprod(D1)
    RW_rank <- data@nGrid - 1L # rank = dimension - 1. # nolintr
  } else {
    # Second-order difference.
    D2 <- D1[-1, -1] %*% D1
    RW <- crossprod(D2)
    RW_rank <- data@nGrid - 2L # nolintr
  }

  .EffFlexi(
    eff = eff,
    eff_dose = eff_dose,
    sigma2W = sigma2W,
    sigma2betaW = sigma2betaW,
    use_fixed = use_fixed,
    rw1 = rw1,
    X = X,
    RW = RW,
    RW_rank = RW_rank,
    data = data
  )
}

## default constructor ----

#' @rdname EffFlexi-class
#' @note Typically, end users will not use the `.DefaultEffFlexi()` function.
#' @export
.DefaultEffFlexi <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))
  EffFlexi(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    sigma2W = c(a = 0.1, b = 0.1),
    sigma2betaW = c(a = 20, b = 50),
    rw1 = FALSE,
    data = empty_data
  )

  data <- DataDual(
    x = c(25, 50, 50, 75, 100, 100, 225, 300),
    y = c(0, 0, 0, 0, 1, 1, 1, 1),
    w = c(0.31, 0.42, 0.59, 0.45, 0.6, 0.7, 0.6, 0.52),
    doseGrid = empty_data@doseGrid,
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 2, 3, 4, 4, 5, 6))
  )

  EffFlexi(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    sigma2W = c(a = 0.1, b = 0.1),
    sigma2betaW = c(a = 20, b = 50),
    rw1 = FALSE,
    data = data
  )
}

# DALogisticLogNormal ----

## class ----

#' `DALogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DALogisticLogNormal`] is the class for the logistic model with bivariate
#' (log) normal prior and data augmentation. This class inherits from the
#' [`LogisticLogNormal`] class.
#'
#' @note We still need to include here formula for the lambda prior.
#'
#' @slot npiece (`number`)\cr the number of pieces in the `PEM`.
#' @slot l (`numeric`)\cr a vector used in the lambda prior.
#' @slot c_par (`numeric`)\cr a parameter used in the lambda prior; according to
#'   Liu's paper, `c_par = 2` is recommended.
#' @slot cond_pem (`flag`)\cr is a conditional piecewise-exponential model used?
#'   (default). Otherwise an unconditional model is used.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`].
#'
#' @aliases DALogisticLogNormal
#' @export
#'
.DALogisticLogNormal <- setClass(
  Class = "DALogisticLogNormal",
  slots = c(
    npiece = "integer",
    l = "numeric",
    c_par = "numeric",
    cond_pem = "logical"
  ),
  prototype = prototype(
    npiece = 3L,
    l = 0.5,
    c_par = 2,
    cond_pem = TRUE
  ),
  contains = "LogisticLogNormal",
  validity = v_model_da_logistic_log_normal
)

## constructor ----

#' @rdname DALogisticLogNormal-class
#'
#' @param npiece (`number`)\cr the number of pieces in the `PEM`.
#' @param l (`numeric`)\cr a vector used in the lambda prior.
#' @param c_par (`numeric`)\cr a parameter used in the lambda prior; according to
#'   Liu's paper, `c_par = 2` is recommended.
#' @param cond_pem (`flag`)\cr is a conditional piecewise-exponential model used?
#'   (default). Otherwise an unconditional model is used.
#' @inheritDotParams LogisticLogNormal
#'
#' @export
#' @example examples/Model-class-DALogisticLogNormal.R
#'
DALogisticLogNormal <- function(
  npiece = 3,
  l,
  c_par = 2,
  cond_pem = TRUE,
  ...
) {
  assert_flag(cond_pem)

  start <- LogisticLogNormal(...)

  datamodel <- function() {
    for (i in 1:nObs) {
      # Part I: describe the logistic model of DLTs vs dose.
      logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)

      # Part II: describe the piecewise exponential.
      # Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing;
      # when indx=0 -> censored, i.e u<T and event=0;
      # when indx=1 -> not censored, i.e. u>=T or event=1;
      indx[i] <- 1 - step(Tmax - u[i] - eps) * (1 - y[i])

      for (j in 1:npiece) {
        # When not censored, i.e DLT!=NA & t[i]=u[i];
        # if t[i]<h[j], d[i,j]=0;
        # if h[j]<t[i]=<h[j+1], d[i,j]=1
        # if h[j+1]<t[i], d[i,j]=0
        # When censored t[i]>u[i] -> d[i,j]=0
        d[i, j] <- y[i] * step(u[i] - h[j] - eps) * step(h[j + 1] - u[i])

        # DLT free survival(time) for patient i in interval I(j);
        # if t[i]<h[j], s[i,j]=0;
        # if h[j]<t[i]<=h[j+1], s[i,j]=t[i]-h[j]
        # if h[j+1]<=t[i], s[i,j]=h[j+1]-h[j]
        s[i, j] <- min(u[i] - h[j], h[j + 1] - h[j]) * step(u[i] - h[j])

        # piecewise exponential hazard rate lambda[j];
        mu_u[i, j] <- lambda[j] * s[i, j]
        mu[i, j] <- d[i, j] * log(lambda[j]) - y[i] * mu_u[i, j]
      }

      # The likelihood function.
      # nolint start
      L_obs[i] <- exp(sum(mu[i, ])) *
        pow(p[i] / A, y[i]) *
        pow(1 - p[i], 1 - y[i]) # Not censored.
      # nolint end
      L_cnsr[i] <- 1 - p[i] * (1 - exp(-sum(mu_u[i, ]))) / A # Censored. # nolintr
      L[i] <- pow(L_obs[i], indx[i]) * pow(L_cnsr[i], 1 - indx[i])

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      g_beta <- 1 / c_par
      for (j in 1:npiece) {
        g_alpha[j] <- l[j] / c_par
        lambda[j] ~ dgamma(g_alpha[j], g_beta)
        mu_T[j] <- lambda[j] * (h[j + 1] - h[j]) # nolintr
      }
      # If cond = 1, then conditional PEM is used and A is defined as
      # the probability to have DLT, i.e. t<T, otherwise
      # cond = 0 and A is just 1 (so no impact in likelihood).
      A <- cond * (1 - exp(-sum(mu_T))) + (1 - cond)
    }
  )

  modelspecs <- function(nObs, Tmax, from_prior) {
    ms <- list(
      prec = start@params@prec,
      mean = start@params@mean,
      npiece = npiece,
      l = l,
      c_par = c_par,
      h = seq(from = 0L, to = Tmax, length = npiece + 1),
      cond = as.integer(cond_pem)
    )
    if (!from_prior) {
      ms <- c(
        list(
          ref_dose = start@ref_dose,
          zeros = rep(0, nObs),
          eps = 1e-10,
          cadj = 1e10
        ),
        ms
      )
    }
    ms
  }

  assert_integerish(npiece, lower = 1)

  .DALogisticLogNormal(
    start,
    npiece = as.integer(npiece),
    l = l,
    c_par = c_par,
    cond_pem = cond_pem,
    datamodel = datamodel,
    priormodel = priormodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "y", "x", "u", "Tmax"),
    sample = c("alpha0", "alpha1", "lambda")
  )
}

## default constructor ----

#' @rdname DALogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultDALogisticLogNormal()` function.
#' @export
.DefaultDALogisticLogNormal <- function() {
  npiece <- 10
  Tmax <- 60

  lambda_prior <- function(k) {
    npiece / (Tmax * (npiece - k + 0.5))
  }

  DALogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 56,
    npiece = npiece,
    l = as.numeric(t(apply(
      as.matrix(c(1:npiece), 1, npiece),
      2,
      lambda_prior
    ))),
    c_par = 2
  )
}

# TITELogisticLogNormal ----

## class ----

#' `TITELogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TITELogisticLogNormal`] is the class for TITE-CRM based on a logistic
#' regression model using a bivariate normal prior on the intercept and log
#' slope parameters.
#'
#' This class inherits from the [`LogisticLogNormal`].
#'
#' @slot weight_method (`string`)\cr the weight function method: either linear
#'   or adaptive; see \insertCite{LiuYinYuan2013;textual}{crmPack}.
#'
#' @details Basically, the adaptive function allocates more weight to each record
#'   than the linear function when DLTs are observed early and less weight when DLTs
#'   are observed late. When DLT times are evenly distributed both weights are similar.
#'   In addition, with more DLTs, the adaptive weights become more extreme
#'   and different from the linear weights.
#'
#' @seealso [`DALogisticLogNormal`].
#'
#' @aliases TITELogisticLogNormal
#' @references
#'   \insertAllCited{}
#' @export
#'
.TITELogisticLogNormal <- setClass(
  Class = "TITELogisticLogNormal",
  slots = c(weight_method = "character"),
  prototype = prototype(weight_method = "linear"),
  contains = "LogisticLogNormal",
  validity = v_model_tite_logistic_log_normal
)

## constructor ----

#' @rdname TITELogisticLogNormal-class
#'
#' @param weight_method (`string`)\cr see the slot description.
#' @inheritDotParams LogisticLogNormal
#'
#' @export
#' @example examples/Model-class-TITELogisticLogNormal.R
#'
TITELogisticLogNormal <- function(weight_method = "linear", ...) {
  assert_character(
    weight_method,
    min.len = 1L,
    max.len = 2L,
    any.missing = FALSE
  )

  start <- LogisticLogNormal(...)

  datamodel <- function() {
    for (i in 1:nObs) {
      logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)

      # The piecewise exponential likelihood. Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing;
      # when indx=0 -> censored, i.e u<T and event=0;
      # when indx=1 -> not censored, i.e. u>=T or event=1;
      L[i] <- pow(p[i], y[i]) * pow((1 - w[i] * p[i]), (1 - y[i]))

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  modelspecs <- function(nObs, u, Tmax, y, from_prior) {
    ms <- list(prec = start@params@prec, mean = start@params@mean)
    # Calculate weights `w` based on the input data.
    if (!from_prior && nObs > 0L) {
      if (weight_method == "linear") {
        w <- u / Tmax
      } else if (weight_method == "adaptive") {
        nDLT <- sum(y)
        if (nDLT > 0) {
          u_dlt <- sort(u[y == 1])
          w <- sapply(u, function(u_i) {
            m <- sum(u_i >= u_dlt)
            w_i <- if (m == 0) {
              u_i / u_dlt[1]
            } else if (m < nDLT) {
              m + (u_i - u_dlt[m]) / (u_dlt[m + 1] - u_dlt[m])
            } else {
              # m == nDLT. nolintr
              m + (u_i - u_dlt[m]) / (Tmax + 0.00000001 - u_dlt[m])
            }
            w_i / (nDLT + 1)
          })
        } else {
          w <- u / Tmax
        }
      }
      w[y == 1] <- 1
      w[u == Tmax] <- 1

      ms <- c(
        list(
          ref_dose = start@ref_dose,
          zeros = rep(0, nObs),
          cadj = 1e10,
          w = w
        ),
        ms
      )
    }
    ms
  }

  .TITELogisticLogNormal(
    start,
    weight_method = weight_method,
    datamodel = datamodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "y", "x")
  )
}

## default constructor ----

#' @rdname TITELogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultTITELogisticLogNormal()` function.
#' @export
.DefaultTITELogisticLogNormal <- function() {
  TITELogisticLogNormal(
    mean = c(0, 1),
    cov = diag(2),
    ref_dose = 1,
    weight_method = "linear"
  )
}

# OneParLogNormalPrior ----

## class ----

#' `OneParLogNormalPrior`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`OneParLogNormalPrior`] is the class for a standard CRM with a normal prior on
#' the log power parameter for the skeleton prior probabilities.
#'
#' @slot skel_fun (`function`)\cr function to calculate the prior DLT probabilities.
#' @slot skel_fun_inv (`function`)\cr inverse function of `skel_fun`.
#' @slot skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @slot sigma2 (`number`)\cr prior variance of log power parameter alpha.
#'
#' @seealso [`ModelLogNormal`].
#'
#' @aliases OneParLogNormalPrior
#' @export
#'
.OneParLogNormalPrior <- setClass(
  Class = "OneParLogNormalPrior",
  slots = c(
    skel_fun = "function",
    skel_fun_inv = "function",
    skel_probs = "numeric",
    sigma2 = "numeric"
  ),
  contains = "GeneralModel",
  validity = v_model_one_par_exp_normal_prior
)

## constructor ----

#' @rdname OneParLogNormalPrior-class
#'
#' @param skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @param dose_grid (`numeric`)\cr dose grid. It must be must be a sorted vector
#'   of the same length as `skel_probs`.
#' @param sigma2 (`number`)\cr prior variance of log power parameter alpha.
#'
#' @export
#' @example examples/Model-class-OneParLogNormalPrior.R
#'
OneParLogNormalPrior <- function(skel_probs, dose_grid, sigma2) {
  assert_probabilities(skel_probs, unique = TRUE, sorted = TRUE) # So that skel_fun_inv exists.
  assert_numeric(
    dose_grid,
    len = length(skel_probs),
    any.missing = FALSE,
    unique = TRUE,
    sorted = TRUE
  )

  skel_fun <- approxfun(x = dose_grid, y = skel_probs, rule = 2)
  skel_fun_inv <- approxfun(x = skel_probs, y = dose_grid, rule = 2)

  .OneParLogNormalPrior(
    skel_fun = skel_fun,
    skel_fun_inv = skel_fun_inv,
    skel_probs = skel_probs,
    sigma2 = sigma2,
    datamodel = function() {
      for (i in 1:nObs) {
        p[i] <- skel_probs[xLevel[i]]^exp(alpha)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      alpha ~ dnorm(0, 1 / sigma2)
    },
    modelspecs = function(from_prior) {
      ms <- list(sigma2 = sigma2)
      if (!from_prior) {
        ms$skel_probs <- skel_probs
      }
      ms
    },
    init = function() {
      list(alpha = 1)
    },
    datanames = c("nObs", "y", "xLevel"),
    sample = "alpha"
  )
}

## default constructor ----

#' @rdname OneParLogNormalPrior-class
#' @return an instance of the `OneParLogNormalPrior` class
#' @export
.DefaultOneParLogNormalPrior <- function() {
  OneParLogNormalPrior(
    skel_probs = seq(from = 0.1, to = 0.9, length = 5),
    dose_grid = 1:5,
    sigma2 = 2
  )
}

# OneParExpPrior ----

## class ----

#' `OneParExpPrior`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OneParExpPrior`] is the class for a standard CRM with an exponential prior
#' on the power parameter for the skeleton prior probabilities. It is an
#' implementation of a version of the one-parameter CRM
#' \insertCite{OQuigleyPepeFisher1990}{crmPack}.
#'
#' @note Typically, end users will not use the `.DefaultOneparExpPrior()` function.
#'
#' @slot skel_fun (`function`)\cr function to calculate the prior DLT probabilities.
#' @slot skel_fun_inv (`function`)\cr inverse function of `skel_fun`.
#' @slot skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @slot lambda (`number`)\cr rate parameter of prior exponential distribution
#'   for theta.
#'
#' @aliases OneParExpPrior
#' @export
#' @references
#'   \insertAllCited{}
#'
.OneParExpPrior <- setClass(
  Class = "OneParExpPrior",
  slots = c(
    skel_fun = "function",
    skel_fun_inv = "function",
    skel_probs = "numeric",
    lambda = "numeric"
  ),
  contains = "GeneralModel",
  validity = v_model_one_par_exp_prior
)

## constructor ----

#' @rdname OneParExpPrior-class
#'
#' @param skel_probs see slot definition.
#' @param dose_grid (`numeric`)\cr dose grid. It must be must be a sorted vector
#'   of the same length as `skel_probs`.
#' @param lambda see slot definition.
#'
#' @export
#' @example examples/Model-class-OneParExpPrior.R
#'
OneParExpPrior <- function(skel_probs, dose_grid, lambda) {
  assert_probabilities(skel_probs, unique = TRUE, sorted = TRUE) # So that skel_fun_inv exists.
  assert_numeric(
    dose_grid,
    len = length(skel_probs),
    any.missing = FALSE,
    unique = TRUE,
    sorted = TRUE
  )

  skel_fun <- approxfun(x = dose_grid, y = skel_probs, rule = 2)
  skel_fun_inv <- approxfun(x = skel_probs, y = dose_grid, rule = 2)

  .OneParExpPrior(
    skel_fun = skel_fun,
    skel_fun_inv = skel_fun_inv,
    skel_probs = skel_probs,
    lambda = lambda,
    datamodel = function() {
      for (i in 1:nObs) {
        p[i] <- skel_probs[xLevel[i]]^theta
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dexp(lambda)
    },
    modelspecs = function(from_prior) {
      ms <- list(lambda = lambda)
      if (!from_prior) {
        ms$skel_probs <- skel_probs
      }
      ms
    },
    init = function() {
      list(theta = 1)
    },
    datanames = c("nObs", "y", "xLevel"),
    sample = "theta"
  )
}

## default constructor ----

#' @rdname OneParExpPrior-class
#' @note Typically, end users will not use the `.DefaultOneParLogNormalPrior()` function.
#' @export
.DefaultOneParExpPrior <- function() {
  OneParExpPrior(
    skel_probs = c(0.1, 0.3, 0.5, 0.7, 0.9),
    dose_grid = 1:5,
    lambda = 2
  )
}

# FractionalCRM ----

## class ----

#' `FractionalCRM`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`FractionalCRM`] is the class for a fractional CRM model based on a one
#' parameter CRM (with normal prior on the log-power parameter) as well as
#' Kaplan-Meier based estimation of the conditional probability to experience a
#' DLT for non-complete observations.
#'
#' This fractional CRM model follows the paper and code by \insertCite{YinZhengXu2013;textual}{crmPack}.
#'
#' @seealso [`TITELogisticLogNormal`].
#'
#' @aliases FractionalCRM
#' @export
#' @references
#'   \insertAllCited{}
#'
.FractionalCRM <- setClass(
  Class = "FractionalCRM",
  contains = "OneParLogNormalPrior"
)

## constructor ----

#' @rdname FractionalCRM-class
#'
#' @inheritDotParams OneParLogNormalPrior
#'
#' @export
#' @example examples/Model-class-FractionalCRM.R
#'
FractionalCRM <- function(...) {
  start <- OneParLogNormalPrior(...)

  # This is adapted from the TITELogisticLogNormal class.
  datamodel <- function() {
    for (i in 1:nObs) {
      p[i] <- skel_probs[xLevel[i]]^exp(alpha)

      # The piecewise exponential likelihood. Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing.
      # Therefore, `yhat` is used instead of `y` for the likelihood f. (see `modelspecs`).
      L[i] <- pow(p[i], yhat[i]) * pow((1 - p[i]), (1 - yhat[i]))

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  modelspecs <- function(nObs, u, Tmax, y, from_prior) {
    ms <- list(sigma2 = start@sigma2)
    if (!from_prior) {
      # Calculate fractional contribution `yhat`
      # based on the input data using the Kaplan-Meier method.
      yhat <- if (nObs > 0) {
        km <- survival::survfit(survival::Surv(u, y) ~ 1)
        s_tau <- tail(km$surv[km$time <= Tmax], 1) # Survival probability = S(Tmax).
        ifelse(
          u < Tmax & y == 0L, # Within the assessment window and so far no DLT.
          yes = 1 -
            s_tau / sapply(u, function(u_i) tail(km$surv[km$time <= u_i], 1)),
          no = y
        )
      } else {
        1L
      }
      ms <- c(
        list(
          skel_probs = start@skel_probs,
          zeros = rep(0, nObs),
          cadj = 1e10,
          yhat = yhat
        ),
        ms
      )
    }
    ms
  }

  .FractionalCRM(
    start,
    datamodel = datamodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "xLevel")
  )
}

## default constructor ----

#' @rdname FractionalCRM-class
#' @note Typically, end users will not use the `.DefaultTITELogisticLogNormal()` function.
#' @export
.DefaultFractionalCRM <- function() {
  FractionalCRM(
    skel_probs = c(0.1, 0.2, 0.3, 0.4),
    dose_grid = c(10, 30, 50, 100),
    sigma2 = 2
  )
}

## class ----

#' `LogisticLogNormalOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticLogNormalOrdinal`] is the class for a logistic lognormal CRM model
#' using an ordinal toxicity scale.
#'
#' @aliases LogisticLogNormalOrdinal
#' @export
.LogisticLogNormalOrdinal <- setClass(
  Class = "LogisticLogNormalOrdinal",
  contains = "ModelLogNormal",
  validity = v_logisticlognormalordinal
)

## constructor ----

#' @rdname LogisticLogNormalOrdinal-class
#' @inheritParams ModelLogNormal
#' @export
#' @example examples/Model-class-LogisticLogNormalOrdinal.R
LogisticLogNormalOrdinal <- function(mean, cov, ref_dose) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalOrdinal(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      alpha[1] ~ dnorm(mean[1], prec[1, 1])
      for (i in 2:(k - 1)) {
        alpha[i] ~ dnorm(mean[i], prec[i, i]) %_% T(, alpha[i - 1])
      }
      gamma ~ dnorm(mean[k], prec[k, k])
      beta <- exp(gamma)
    },
    datamodel = function() {
      for (i in 1:nObs) {
        xhat[i] <- log(x[i] / ref_dose)
        for (j in 1:(k - 1)) {
          z[i, j] <- alpha[j] + beta * xhat[i]
          p[i, j] <- exp(z[i, j]) / (1 + exp(z[i, j]))
          tox[i, j] ~ dbern(p[i, j])
        }
      }
    },
    modelspecs = function(y, from_prior) {
      ms <- list(
        mean = params@mean,
        prec = params@prec,
        k = length(mean)
      )
      if (!from_prior) {
        ms$tox <- array(dim = c(length(y), length(mean) - 1))
        for (i in seq_along(y)) {
          for (j in 1:(ms$k - 1)) {
            ms$tox[i, j] <- y[i] >= j
          }
        }
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(
        alpha = sapply(1:(length(mean) - 1), function(x) -(x + 1)),
        gamma = 1
      )
    },
    datanames = c("nObs", "x"),
    # Need to provide JAGS column names here
    sample = c(paste0("alpha[", 1:(length(mean) - 1), "]"), "beta")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalOrdinal-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormalOrdinal()` function.
#' @export
.DefaultLogisticLogNormalOrdinal <- function() {
  LogisticLogNormalOrdinal(
    mean = c(-3, -4, 1),
    cov = diag(c(3, 4, 1)),
    ref_dose = 50
  )
}

#' Format a `doseGrid` for Printing
#'
#' @param grid (`numeric`)\cr the dose grid
#' @param units (`character`)\cr The units in which the values in `doseGrid` are
#' @param fmt (`character`)\cr The format used to display values in `doseGrid`.
#' If `NA`, grid values are not pre-formatted
#' @param ... not used at present
#' measured.  Appended to each value in `doseGrid` when `knit_print`ed.  The
#' default, `NA`, omits the units.
#' @return A character string containing the formatted dose grid.  If the grid
#' is `c(1, 2, 3)` and `units` is `"mg"`, the returned value is `"1 mg, 2 mg and 3 mg"`.
#' @keywords internal
h_get_formatted_dosegrid <- function(grid, units = NA, fmt = NA, ...) {
  assert_numeric(
    grid,
    lower = 0,
    min.len = 2,
    unique = TRUE,
    finite = TRUE,
    sorted = TRUE,
    any.missing = FALSE
  )
  assert_character(units, len = 1)

  n <- length(grid)
  units <- h_prepare_units(units)
  formattedGrid <- if (is.na(fmt)) {
    as.character(grid)
  } else {
    sprintf(fmt, grid)
  }
  paste0(
    paste(
      lapply(
        formattedGrid[1:(n - 1)],
        paste0,
        sep = units
      ),
      collapse = ", "
    ),
    " and ",
    formattedGrid[n],
    paste0(units, ".\n\n")
  )
}

#' Set Column Headers in Custom `knit_print` Methods
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`ANY`)\cr object that will be printed
#' @param param (`list`)\cr A list of the `...` parameters passed to `knit_print`
#' @param summarise (`flag`)\cr Is the object to be summarised (default) or listed?
#' @return A character vector of column names.
#' @noRd
h_knit_print_set_headers <- function(x, param, summarise, ...) {
  UseMethod("h_knit_print_set_headers")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.GeneralData <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "DLT?")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataDA <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c(
        "ID",
        "Cohort",
        "Dose",
        "Tox",
        "U",
        "T0",
        "TMax"
      )
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataGrouped <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "Group", "Tox")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Group", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c(
        "Cohort",
        "Group",
        "Evaluable",
        "With Toxicities"
      )
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataParts <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Part", "Cohort", "Dose", "Tox")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_set_headers.DataOrdinal <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c(
        "ID",
        "Cohort",
        "Dose",
        paste0("Cat", 0:(length(x@yCategories) - 1))
      )
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", names(x@yCategories))
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", names(x@yCategories))
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataDual <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "Tox", "W")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' Select Columns to Print in Custom `knit_print` Methods
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`ANY`)\cr object that will be printed
#' @param ... Not used at present.
#' @return A tidied version of `x`, containing only the selected columns.
#' @noRd
h_knit_print_select_columns <- function(x, ...) {
  UseMethod("h_knit_print_select_columns")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.GeneralData <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.Data <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataParts <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Part", "Cohort", "Dose", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataOrdinal <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", tidyselect::starts_with("Cat"))
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataDA <- function(x, param, summarise, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox", "U", "T0", "TMax")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataGrouped <- function(x, param, summarise, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Group", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataDual <- function(x, param, summarise, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox", "W")
}

#' Summarise a `Data` Object by Dose or Cohort for Display in Custom `knit_print` Methods
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`ANY`)\cr object that will be printed
#' @param full_grid (`flag`)\cr Should the full grid be included or only those
#' doses with at least one evaluable participant?
#' @param ... Not used at present.
#' @return A tibble containing the summarised data
#' @noRd
h_knit_print_summarise <- function(x, summarise, full_grid, ...) {
  UseMethod("h_knit_print_summarise")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_summarise
#' @noRd
h_knit_print_summarise.GeneralData <- function(x, summarise, full_grid, ...) {
  xTidy <- x %>% tidy()
  xTidy <- xTidy %>%
    dplyr::group_by(.data[[stringr::str_to_title(summarise)]]) %>%
    dplyr::summarise(
      N = dplyr::n(),
      ToxCount = sum(Tox)
    )
  if (full_grid && summarise == "dose") {
    xTidy <- xTidy %>%
      tidyr::complete(
        Dose = x@doseGrid,
        fill = list(ToxCount = 0, N = 0)
      )
  }
  xTidy
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_summarise
#' @noRd
h_knit_print_summarise.DataOrdinal <- function(x, summarise, full_grid, ...) {
  xTidy <- x %>% tidy()
  xTidy <- xTidy %>%
    dplyr::group_by(.data$Dose) %>%
    dplyr::summarise(
      N = dplyr::n(),
      dplyr::across(tidyselect::starts_with("Cat"), sum)
    )
  if (full_grid && summarise == "dose") {
    replace_list <- as.list(
      c(
        "N",
        names(xTidy)[which(stringr::str_detect(names(xTidy), "Cat\\d+"))]
      )
    )
    # Create a list whose names are the columns in which we need to replace NAs
    # and whose values are 0
    names(replace_list) <- sapply(replace_list, \(x) x)
    replace_list <- lapply(replace_list, \(x) 0)
    # Expand the tibble and do the replacement
    xTidy <- tidyr::expand_grid(Dose = x@doseGrid) %>%
      dplyr::left_join(xTidy, by = "Dose") %>%
      tidyr::replace_na(replace_list)
  }
  xTidy
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_summarise
#' @noRd
h_knit_print_summarise.DataGrouped <- function(x, summarise, full_grid, ...) {
  xTidy <- x %>% tidy()
  xTidy <- xTidy %>%
    dplyr::group_by(.data[[stringr::str_to_title(summarise)]], .data$Group) %>%
    dplyr::summarise(
      N = dplyr::n(),
      ToxCount = sum(Tox)
    )
  if (full_grid && summarise == "dose") {
    xTidy <- tidyr::expand_grid(
      Dose = x@doseGrid,
      Group = c("mono", "combo")
    ) %>%
      dplyr::left_join(xTidy, by = c("Dose", "Group")) %>%
      tidyr::replace_na(list(N = 0, ToxCount = 0))
  }
  xTidy
}

#' Print a `GeneralData` Object in a Markdown or Quarto Chunk
#'
#' @param label (`character`)\cr How to describe the participants in the trial.
#' See Usage Notes below.
#' @param full_grid (`flag`)\cr Should the full dose grid appear in the output table
#' or simply those doses for whom at least one evaluable participant is available?
#' Ignored unless `summarise == "dose"`.
#' @param summarise (`character`)\cr How to summarise the observed data.  The default,
#' `"none"`, lists observed data at the participant level.  `"dose"` presents
#' participant counts by dose and `"cohort"` by cohort.
#' @param summarize (`character`)\cr Synonym for `summarise`
#' @param format_func (`function`)\cr The function used to format the participant table.
#' The default applies no formatting.  Obvious alternatives include `kableExtra::kable_styling`.
#' @param ... passed to [knitr::kable()]
#' @section Usage Notes:
#' `label` describes the trial's participants.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a single participant and the second describes all other
#' situations.  If of length 1, the character `s` is appended to the value
#' when the number of participants is not 1.
#' The default values of `col.names` and `caption` vary depending on the summary
#' requested. The default values can be overridden by passing `col.names` and
#' `caption` in the function call.
#'
#' @inheritParams h_get_formatted_dosegrid
#' @export
#' @method knit_print GeneralData
#' @rdname knit_print
knit_print.GeneralData <- function(
  x,
  ...,
  asis = TRUE,
  label = c("participant", "participants"),
  full_grid = FALSE,
  summarise = c("none", "dose", "cohort"),
  summarize = summarise,
  units = NA,
  format_func = h_knit_format_func
) {
  # Validate
  assert_flag(asis)
  assert_flag(full_grid)
  assert_function(format_func)
  summarise <- match.arg(summarise)
  summarize <- match.arg(summarize)

  if (is.na(summarise) || is.null(summarise)) {
    summarise <- summarize
  }
  assert_choice(summarise, c("none", "dose", "cohort"))
  # Initialise
  label <- h_prepare_labels(label)
  param <- list(...)

  # Execute
  param <- h_knit_print_set_headers(x, param, summarise, ...)
  if (summarise == "none") {
    if (!("caption" %in% names(param))) {
      param[["caption"]] <- paste("Evaluable", label[2], "to-date")
    }
    xTidy <- h_knit_print_select_columns(x)
  } else {
    xTidy <- h_knit_print_summarise(x, summarise, full_grid)
    if (!("caption" %in% names(param))) {
      param[["caption"]] <- paste0("Summarised by ", summarise)
    }
  }
  param[["x"]] <- xTidy
  rv <- if (length(x@x) > 0) {
    paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n")
  } else {
    paste("No", label[2], "are yet evaluable.\n\n")
  }
  rv <- paste0(
    rv,
    paste0(
      "\n\nThe dose grid is ",
      h_get_formatted_dosegrid(
        grid = x@doseGrid,
        units = units,
        ...
      ),
      ""
    ),
    "\n\n",
    collpase = "\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Used to obtain expected format.
#' @keywords internal
h_knit_format_func <- function(x) {
  kableExtra::kable_styling(
    x,
    bootstrap_options = c("striped", "hover", "condensed")
  )
}

#' @export
#' @method knit_print DataParts
#' @rdname knit_print
knit_print.DataParts <- function(
  x,
  ...,
  asis = TRUE,
  label = c("participant", "participants"),
  full_grid = FALSE,
  summarise = c("none", "dose", "cohort"),
  summarize = summarise,
  units = NA,
  format_func = h_knit_format_func
) {
  rv <- NextMethod()
  rv <- paste0(
    rv,
    paste0(
      "\n\nThe part 1 ladder is ",
      h_get_formatted_dosegrid(x@part1Ladder, units)
    ),
    paste0("\n\nThe next part is Part ", x@nextPart, ".\n\n")
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @include helpers_knitr_CohortSize.R

# Increments ----

#' Render a `IncrementsRelative` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed to [knitr::kable()]
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
#' of `caption` is `"Defined by highest dose administered so far"`.  These
#' values can be overridden by passing `col.names` and `caption` in the function
#' call.
#' @export
#' @method knit_print IncrementsRelative
#' @rdname knit_print
knit_print.IncrementsRelative <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Min", "Max", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by highest dose administered so far"
  }
  x <- tidy(x)
  param[["x"]] <- x
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("Dose" = 2, " " = 1)
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsRelativeDLT` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed to [knitr::kable()]
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
#' of `caption` is `"Defined by number of DLTs reported so far"`. These values
#' can be overridden by passing `col.names` and `caption` in the function call.
#' @export
#' @method knit_print IncrementsRelativeDLT
#' @rdname knit_print
knit_print.IncrementsRelativeDLT <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Min", "Max", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by number of DLTs reported so far"
  }

  param[["x"]] <- tidy(x)
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("No DLTs" = 2, " " = 1)
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsDoseLevels` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @rdname knit_print
#' @method knit_print IncrementsDoseLevels
knit_print.IncrementsDoseLevels <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "The maximum increment between cohorts is ",
    x@levels,
    ifelse(x@levels == 1, " level", " levels"),
    " relative to the ",
    ifelse(
      x@basis_level == "last",
      "dose used in the previous cohort.",
      "highest dose used so far."
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsHSRBeta` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @method knit_print IncrementsHSRBeta
#' @rdname knit_print
knit_print.IncrementsHSRBeta <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "The maximum increment is defined by a hard safety rule, independent of the CRM model, ",
    " and based on a beta(",
    x@a,
    ", ",
    x@b,
    ") ",
    "prior with a target toxicity rate of ",
    x@target,
    " and a probability threshold of ",
    x@prob,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsMin` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @method knit_print IncrementsMin
#' @rdname knit_print
knit_print.IncrementsMin <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "The minimum of the increments defined in the following rules:",
    paste0(
      lapply(
        x@increments_list,
        function(x, ...) {
          knit_print(x, asis = asis, ...)
        }
      ),
      collapse = "\n"
    ),
    "\n\n",
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsOrdinal` object
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` method of the standard rule
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @method knit_print IncrementsOrdinal
#' @rdname knit_print
knit_print.IncrementsOrdinal <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "Based on a toxicity grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
    "\n\n",
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsRelativeParts` object
#'
#' @inherit knit_print.CohortSizeConst return
#' @param tox_label (`character`)\cr The word used to describe toxicities.  See
#' Usage Notes below.
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' `label` defines how toxicities are described.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a single toxicity and the second describes all other
#' toxicity counts.  If of length 1, the character `s` is appended to the value
#' describing a single toxicity.
#'
#' @export
#' @method knit_print IncrementsRelativeParts
#' @rdname knit_print
knit_print.IncrementsRelativeParts <- function(
  x,
  ...,
  asis = TRUE,
  tox_label = c("toxicity", "toxicities")
) {
  assert_flag(asis)

  tox_label <- h_prepare_labels(tox_label)
  rv <- paste0(
    "The maximum increment in Part 1 is defined by the `part1Ladder` slot of ",
    "the associated `DataParts` object.\n\n",
    "If no ",
    tox_label[2],
    " are reported in Part 1, the starting dose for Part 2 ",
    "will be ",
    ifelse(
      x@clean_start == 0,
      "the highest dose used in Part 1.\n\n",
      paste0(
        x@clean_start,
        ifelse(abs(x@clean_start) == 1, " dose ", " doses "),
        ifelse(x@clean_start < 0, "below ", "above "),
        "the highest dose used in Part 1.\n\n"
      )
    ),
    "If one or more ",
    tox_label[2],
    " are reported in Part 1, the starting dose for Part 2 ",
    "will be ",
    ifelse(
      x@dlt_start == 0,
      "the highest dose used in Part 1.\n\n",
      paste0(
        abs(x@dlt_start),
        ifelse(abs(x@dlt_start) == 1, " dose ", " doses "),
        ifelse(x@dlt_start < 0, "below ", "above "),
        "the highest dose used in Part 1.\n\n"
      )
    ),
    "Once Part 2 has started, the maximum increment in dose levels will be based ",
    "on the number of ",
    tox_label[2],
    " reported so far, as described in the ",
    "following table:"
  )

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- paste0(
      "Defined by the number of ",
      tox_label[2],
      " reported so far"
    )
  }
  header <- c(2, 1)
  headerLabel <- tox_label[2]
  substr(headerLabel, 1, 1) <- toupper(substr(headerLabel, 1, 1))
  names(header) <- c(headerLabel, " ")
  param[["x"]] <- tibble(
    intervals = x@intervals
  ) %>%
    h_range_to_minmax(intervals) %>%
    tibble::add_column(increments = c(0, x@increments))
  d_tab <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    header
  )
  rv <- paste(rv, d_tab, "\n\n")
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsRelativeDLTCurrent` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param tox_label (`character`)\cr The word used to describe toxicities.  See
#' Usage Notes below.
#' @param ... passed to [knitr::kable()]
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
#' of `caption` is `"Defined by number of DLTs in the current cohort"`. These values
#' can be overridden by passing `col.names` and `caption` in the function call.
#'
#' `tox_label` defines how toxicities are described.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a single toxicity and the second describes all other
#' toxicity counts.  If of length 1, the character `s` is appended to the value
#' describing a single toxicity.
#'
#' @export
#' @method knit_print IncrementsRelativeDLTCurrent
#' @rdname knit_print
knit_print.IncrementsRelativeDLTCurrent <- function(
  x,
  ...,
  asis = TRUE,
  tox_label = c("DLT", "DLTs")
) {
  assert_flag(asis)
  assert_character(tox_label, min.len = 1, max.len = 2, any.missing = FALSE)

  if (length(tox_label) == 1) {
    tox_label[2] <- paste0(tox_label[1], "s")
  }

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Min", "Max", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- paste0(
      "Defined by number of ",
      tox_label[2],
      " reported in the current cohort"
    )
  }
  param[["x"]] <- tidy(x)
  header_text <- c(2, 1)
  names(header_text) <- c(paste0("No ", tox_label[2]), " ")
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    header_text
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @include helpers.R
#' @include Rules-validity.R
#' @include CrmPackClass-class.R
NULL

# NextBest ----

## class ----

#' `NextBest`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBest`] is a virtual class for finding next best dose, from which all
#' other specific next best dose classes inherit.
#'
#' @seealso [`NextBestEWOC`], [`NextBestMTD`], [`NextBestNCRM`],
#'   [`NextBestNCRMLoss`], [`NextBestThreePlusThree`], [`NextBestDualEndpoint`],
#'   [`NextBestMinDist`], [`NextBestInfTheory`], [`NextBestTD`],
#'   [`NextBestTDsamples`], [`NextBestMaxGain`], [`NextBestMaxGainSamples`],
#'   [`NextBestProbMTDLTE`], [`NextBestProbMTDMinDist`], [`NextBestOrdinal`].
#'
#' @aliases NextBest
#' @export
#'
setClass(
  Class = "NextBest",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname NextBest-class
#' @note Typically, end users will not use the `DefaultNextBest()` function.
#' @export
.DefaultNextBest <- function() {
  stop(paste0(
    "Class NextBest should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

#' `NextBestEWOC`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestEWOC`] is the class implementing Escalation With Overdose Control
#' (EWOC). It recommends the highest possible dose subject to a probabilistic
#' constraint that the posterior probability of overdosing does not exceed
#' `max_overdose_prob`. Overdosing is defined as the model-based toxicity
#' probability lying inside the interval given by `overdose`.
#'
#' @slot target (`proportion`)\cr target toxicity probability to be
#'   achieved, below `overdose[1]`; only used for simulation reporting purposes.
#' @slot overdose (`numeric`)\cr the (exclusive) lower and (inclusive) upper boundaries of the
#'   toxicity probability interval considered an overdose region. The prototype
#'   uses `c(0.35, 1)` meaning probabilities > 0.35 are treated as overly toxic.
#' @slot max_overdose_prob (`proportion`)\cr maximum acceptable posterior
#'   probability that the next recommended dose is in the overdose interval.
#'
#' @seealso [`NextBest`], other next-best classes listed in its documentation.
#'
#' @aliases NextBestEWOC
#' @export
.NextBestEWOC <- setClass(
  Class = "NextBestEWOC",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  ),
  contains = "NextBest",
  validity = v_next_best_ewoc
)

## constructor ----

#' @rdname NextBestEWOC-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestEWOC.R
NextBestEWOC <- function(target, overdose, max_overdose_prob) {
  .NextBestEWOC(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob
  )
}

## default constructor ----

#' @rdname NextBestEWOC-class
#' @note Typically, end users will not use the `.DefaultNextBestEWOC()` function.
#' @export
.DefaultNextBestEWOC <- function() {
  NextBestEWOC(
    target = 0.3,
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )
}

# NextBestMTD ----

## class ----

#' `NextBestMTD`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMTD`] is the class for next best dose based on MTD estimate.
#'
#' @slot target (`proportion`)\cr target toxicity probability, except 0 or 1.
#' @slot derive (`function`)\cr a function which derives the final next best MTD
#'   estimate, based on vector of posterior MTD samples. It must therefore accept
#'   one and only one argument, which is a numeric vector, and return a number.
#'
#' @aliases NextBestMTD
#' @export
#'
.NextBestMTD <- setClass(
  Class = "NextBestMTD",
  slots = c(
    target = "numeric",
    derive = "function"
  ),
  prototype = prototype(
    target = 0.3,
    derive = function(mtd_samples) {
      quantile(mtd_samples, probs = 0.3)
    }
  ),
  contains = "NextBest",
  validity = v_next_best_mtd
)

## constructor ----

#' @rdname NextBestMTD-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMTD.R
#'
NextBestMTD <- function(target, derive) {
  .NextBestMTD(
    target = target,
    derive = derive
  )
}

## default constructor ----

#' @rdname NextBestMTD-class
#' @note Typically, end users will not use the `.DefaultNextBestMTD()` function.
#' @export
.DefaultNextBestMTD <- function() {
  NextBestMTD(
    target = 0.33,
    derive = function(mtd_samples) {
      quantile(mtd_samples, probs = 0.25)
    }
  )
}

# NextBestNCRM ----

## class ----

#' `NextBestNCRM`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestNCRM`] is the class for next best dose that finds the next dose
#' with high posterior probability to be in the target toxicity interval.
#'
#' @details To avoid numerical problems, the dose selection algorithm has been
#' implemented as follows: First admissible doses are found, which are those
#' with probability to fall in `overdose` category being below `max_overdose_prob`.
#' Next, within the admissible doses, the maximum probability to fall in the
#' `target` category is calculated. If that is above 5% (i.e. it is not just
#' numerical error), then the corresponding dose is the next recommended dose.
#' Otherwise, the highest admissible dose is the next recommended dose.
#'
#' @slot target (`numeric`)\cr the target toxicity interval (limits included).
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included). It is used to filter probability samples.
#' @slot max_overdose_prob (`proportion`)\cr maximum overdose posterior
#'   probability that is allowed, except 0 or 1.
#'
#' @aliases NextBestNCRM
#' @export
#'
.NextBestNCRM <- setClass(
  Class = "NextBestNCRM",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  ),
  contains = "NextBest",
  validity = v_next_best_ncrm
)

## constructor ----

#' @rdname NextBestNCRM-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestNCRM.R
#'
NextBestNCRM <- function(target, overdose, max_overdose_prob) {
  .NextBestNCRM(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob
  )
}

## default constructor ----

#' @rdname NextBestNCRM-class
#' @note Typically, end users will not use the `.DefaultNextBestNCRM()` function.
#' @export
.DefaultNextBestNCRM <- function() {
  NextBestNCRM(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )
}

# NextBestNCRMLoss ----

## class ----

#' `NextBestNCRMLoss`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestNCRMLoss`] is the class based on NCRM rule and loss function.
#' This class is similar to [`NextBestNCRM`] class, but differences are the
#' addition of loss function and re-defined toxicity intervals, see each
#' toxicity interval documentation and the note for details. As in NCRM rule, first admissible doses are found,
#' which are those with probability to fall in overdose category being below
#' `max_overdose_prob`. Next, within the admissible doses, the loss function is
#' calculated, i.e. `losses` %*% `target`. Finally, the corresponding
#' dose with lowest loss function (Bayes risk) is recommended for the next dose.
#'
#' @slot target (`numeric`)\cr the target toxicity interval (limits included).
#'   It has to be a probability range excluding 0 and 1.
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included) or the excessive toxicity interval (lower
#'   limit excluded, upper limit included) if unacceptable is not provided.
#'   It has to be a probability range. It is used to filter probability samples.
#' @slot unacceptable (`numeric`)\cr an unacceptable toxicity
#'   interval (lower limit excluded, upper limit included). This must be
#'   specified if the `overdose` does not include 1. Otherwise, it is `c(1, 1)`
#'   (default), which is essentially a scalar equals 1. It has to be a
#'   probability range.
#' @slot losses (`numeric`)\cr a vector specifying the loss function. If the
#'   `unacceptable` is provided, the vector length must be 4, otherwise 3.
#'
#' @note The loss function should be a vector of either 3 or 4 values.
#'   This is because the loss function values must be specified for each
#'   interval, that is under-dosing, target toxicity, and overdosing toxicity or
#'   under-dosing, target toxicity, overdosing (excessive) toxicity, and
#'   unacceptable toxicity intervals.
#'
#' @aliases NextBestNCRMLoss
#' @export
#'
.NextBestNCRMLoss <- setClass(
  Class = "NextBestNCRMLoss",
  slots = c(
    unacceptable = "numeric",
    losses = "numeric"
  ),
  prototype = prototype(
    unacceptable = c(1, 1),
    losses = c(1, 0, 2)
  ),
  contains = "NextBestNCRM",
  validity = v_next_best_ncrm_loss
)

## constructor ----

#' @rdname NextBestNCRMLoss-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param unacceptable (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition in [`NextBestNCRM`].
#' @param losses (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestNCRMLoss.R
#'
NextBestNCRMLoss <- function(
  target,
  overdose,
  unacceptable = c(1, 1),
  max_overdose_prob,
  losses
) {
  .NextBestNCRMLoss(
    target = target,
    overdose = overdose,
    unacceptable = unacceptable,
    max_overdose_prob = max_overdose_prob,
    losses = losses
  )
}

## default constructor ----

#' @rdname NextBestNCRMLoss-class
#' @note Typically, end users will not use the `.DefaultNextBestnCRMLoss()` function.
#' @export
.DefaultNextBestNCRMLoss <- function() {
  NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.25,
    losses = c(1, 0, 1, 2)
  )
}


# NextBestThreePlusThree ----

## class ----

#' `NextBestThreePlusThree`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestThreePlusThree`] is the class for next best dose that
#' implements the classical 3+3 dose recommendation. No input is required,
#' hence this class has no slots.
#'
#' @aliases NextBestThreePlusThree
#' @export
#'
.NextBestThreePlusThree <- setClass(
  Class = "NextBestThreePlusThree",
  contains = "NextBest"
)

## constructor ----

#' @rdname NextBestThreePlusThree-class
#'
#' @export
#' @examples
#' # Next best dose class object using the classical 3+3 design.
#' my_next_best <- NextBestThreePlusThree()
NextBestThreePlusThree <- function() {
  .NextBestThreePlusThree()
}

## default constructor ----

#' @rdname NextBestThreePlusThree-class
#' @note Typically, end users will not use the `.DefaultNextBestThreePlusThree()` function.
#' @export
.DefaultNextBestThreePlusThree <- function() {
  NextBestThreePlusThree()
}

# NextBestDualEndpoint ----

## class ----

#' `NextBestDualEndpoint`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestDualEndpoint`] is the class for next best dose that is based on the
#' dual endpoint model.
#'
#' @details Under this rule, at first admissible doses are found, which are those
#' with toxicity probability to fall in `overdose` category and being below
#' `max_overdose_prob`. Next, it picks (from the remaining admissible doses) the
#' one that maximizes the probability to be in the `target` biomarker range. By
#' default (`target_relative = TRUE`) the target is specified as relative to the
#' maximum biomarker level across the dose grid or relative to the `Emax`
#' parameter in case a parametric model was selected (i.e. [`DualEndpointBeta`],
#' [`DualEndpointEmax`]). However, if `target_relative = FALSE`, then the
#' absolute biomarker range can be used as a target.
#'
#' @slot target (`numeric`)\cr the biomarker target range that needs to be
#'   reached. For example, the target range \eqn{(0.8, 1.0)} and
#'   `target_relative = TRUE` means that we target a dose with at least
#'   \eqn{80\%} of maximum biomarker level. As an other example,
#'   \eqn{(0.5, 0.8)} would mean that we target a dose between \eqn{50\%} and
#'   \eqn{80\%} of the maximum biomarker level.
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included).
#' @slot max_overdose_prob (`proportion`)\cr maximum overdose probability that
#'   is allowed.
#' @slot target_relative (`flag`)\cr is `target` specified as relative? If
#'   `TRUE`, then the `target` is interpreted relative to the maximum, so it
#'   must be a probability range. Otherwise, the `target` is interpreted as
#'   absolute biomarker range.
#' @slot target_thresh (`proportion`)\cr a target probability threshold that
#'   needs to be fulfilled before the target probability will be used for
#'   deriving the next best dose (default to 0.01).
#'
#' @aliases NextBestDualEndpoint
#' @export
#'
.NextBestDualEndpoint <- setClass(
  Class = "NextBestDualEndpoint",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric",
    target_relative = "logical",
    target_thresh = "numeric"
  ),
  prototype = prototype(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25,
    target_relative = TRUE,
    target_thresh = 0.01
  ),
  contains = "NextBest",
  validity = v_next_best_dual_endpoint
)

## constructor ----

#' @rdname NextBestDualEndpoint-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition.
#' @param target_relative (`flag`)\cr see slot definition.
#' @param target_thresh (`proportion`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestDualEndpoint.R
#'
NextBestDualEndpoint <- function(
  target,
  overdose,
  max_overdose_prob,
  target_relative = TRUE,
  target_thresh = 0.01
) {
  .NextBestDualEndpoint(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob,
    target_relative = target_relative,
    target_thresh = target_thresh
  )
}

## default constructor ----

#' @rdname NextBestDualEndpoint-class
#' @note Typically, end users will not use the `.DefaultNextBestDualEndpoint()` function.
#' @export
.DefaultNextBestDualEndpoint <- function() {
  NextBestDualEndpoint(
    target = c(200, 300),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25,
    target_relative = FALSE
  )
}

# NextBestMinDist ----

## class ----

#' `NextBestMinDist`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMinDist`] is the class for next best dose that is based on minimum
#' distance to target probability.
#'
#' @slot target (`proportion`)\cr single target toxicity probability, except
#'   0 or 1.
#'
#' @aliases NextBestMinDist
#' @export
#'
.NextBestMinDist <- setClass(
  Class = "NextBestMinDist",
  slots = c(
    target = "numeric"
  ),
  prototype = prototype(
    target = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_min_dist
)

## constructor ----

#' @rdname NextBestMinDist-class
#'
#' @param target (`proportion`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMinDist.R
#'
NextBestMinDist <- function(target) {
  .NextBestMinDist(target = target)
}

## default constructor ----

#' @rdname NextBestMinDist-class
#' @note Typically, end users will not use the `.DefaultNextBestMinDist()` function.
#' @export
.DefaultNextBestMinDist <- function() {
  NextBestMinDist(target = 0.3)
}

# NextBestInfTheory ----

## class ----

#' `NextBestInfTheory`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestInfTheory`] is the class for next best dose that is based on
#' information theory as proposed in https://doi.org/10.1002/sim.8450.
#'
#' @slot target (`proportion`)\cr target toxicity probability, except 0 or 1.
#' @slot asymmetry (`number`)\cr value of the asymmetry exponent in the
#'   divergence function that describes the rate of penalization for overly
#'   toxic does. It must be a value from \eqn{(0, 2)} interval.
#'
#' @aliases NextBestInfTheory
#' @export
#'
.NextBestInfTheory <- setClass(
  Class = "NextBestInfTheory",
  slots = c(
    target = "numeric",
    asymmetry = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    asymmetry = 1
  ),
  contains = "NextBest",
  validity = v_next_best_inf_theory
)

## constructor ----

#' @rdname NextBestInfTheory-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param asymmetry (`number`)\cr see slot definition.
#'
#' @export
#'
NextBestInfTheory <- function(target, asymmetry) {
  .NextBestInfTheory(target = target, asymmetry = asymmetry)
}

## default constructor ----

#' @rdname NextBestInfTheory-class
#' @note Typically, end users will not use the `.DefaultNextBestInfTheory()` function.
#' @export
.DefaultNextBestInfTheory <- function() {
  NextBestInfTheory(0.33, 1.2)
}

# NextBestTD ----

## class ----

#' `NextBestTD`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestTD`] is the class to find a next best dose based on pseudo
#' DLT model without samples. Namely, it is to find two next best doses, one
#' for allocation during the trial and the second for final recommendation at
#' the end of a trial without involving any samples, i.e. only DLT responses
#' will be incorporated for the dose-allocation. This is based solely on the
#' probabilities of the occurrence of a DLT obtained by using the modal estimates
#' of the model parameters. There are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model class.
#'
#' @slot prob_target_drt (`proportion`)\cr the target probability (except 0 or 1)
#'   of the occurrence of a DLT to be used during the trial.
#' @slot prob_target_eot (`proportion`)\cr the target probability (except 0 or 1)
#'   of the occurrence of a DLT to be used at the end of the trial.
#'
#' @aliases NextBestTD
#' @export
#'
.NextBestTD <- setClass(
  Class = "NextBestTD",
  slots = c(
    prob_target_drt = "numeric",
    prob_target_eot = "numeric"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_td
)

## default constructor ----

#' @rdname NextBestTD-class
#' @note Typically, end users will not use the `.DefaultNextBestTD()` function.
#' @export
.DefaultNextBestTD <- function() {
  NextBestTD(0.35, 0.3)
}

## constructor ----

#' @rdname NextBestTD-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition.
#' @param prob_target_eot (`proportion`)\cr see slot definition.
#'
#' @export
#' @examples
#' my_next_best <- NextBestTD(0.35, 0.3)
NextBestTD <- function(prob_target_drt, prob_target_eot) {
  .NextBestTD(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot
  )
}

# NextBestTDsamples ----

## class ----

#' `NextBestTDsamples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestTDsamples`] is the class to find a next best dose based on Pseudo
#' DLT model with samples. Namely, it is to find two next best doses, one
#' for allocation during the trial and the second for final recommendation at
#' the end of a trial. Hence, there are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#'
#' @slot derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples, the target dose that has the probability of the occurrence of
#'   DLT equals to either the `prob_target_drt` or `prob_target_eot`. It must
#'   therefore accept one and only one argument, which is a numeric vector, and
#'   return a number.
#'
#' @aliases NextBestTDsamples
#' @export
#'
.NextBestTDsamples <- setClass(
  Class = "NextBestTDsamples",
  slots = c(
    derive = "function"
  ),
  prototype = prototype(
    derive = function(dose_samples) {
      quantile(dose_samples, prob = 0.3)
    }
  ),
  contains = "NextBestTD",
  validity = v_next_best_td_samples
)

## constructor ----

#' @rdname NextBestTDsamples-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition in [`NextBestTD`].
#' @param prob_target_eot (`proportion`)\cr see slot definition in [`NextBestTD`].
#' @param derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestTDsamples.R
#'
NextBestTDsamples <- function(prob_target_drt, prob_target_eot, derive) {
  .NextBestTDsamples(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot,
    derive = derive
  )
}

## default constructor ----

#' @rdname NextBestTDsamples-class
#' @note Typically, end users will not use the `.DefaultNextBestTDsamples()` function.
#' @export
.DefaultNextBestTDsamples <- function() {
  NextBestTDsamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, probs = 0.3))
    }
  )
}


# NextBestMaxGain ----

## class ----

#' `NextBestMaxGain`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMaxGain`] is the class to find a next best dose with maximum gain
#' value based on a pseudo DLT and efficacy models without samples. It is based
#' solely on the probabilities of the occurrence of a DLT and the values
#' of the mean efficacy responses obtained by using the modal estimates of the
#' DLT and efficacy model parameters. There are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model and [`ModelEff`]
#' classes (except [`EffFlexi`]).
#'
#' @slot prob_target_drt (`proportion`)\cr the target probability of the
#'   occurrence of a DLT to be used during the trial.
#' @slot prob_target_eot (`proportion`)\cr the target probability of the
#'   occurrence of a DLT to be used at the end of the trial.
#'
#' @aliases NextBestMaxGain
#' @export
#'
.NextBestMaxGain <- setClass(
  Class = "NextBestMaxGain",
  slots = c(
    prob_target_drt = "numeric",
    prob_target_eot = "numeric"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_td
)

## constructor ----

#' @rdname NextBestMaxGain-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition.
#' @param prob_target_eot (`proportion`)\cr see slot definition.
#'
#' @export
#' @examples
#' my_next_best <- NextBestMaxGain(0.35, 0.3)
NextBestMaxGain <- function(prob_target_drt, prob_target_eot) {
  .NextBestMaxGain(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot
  )
}

## default constructor ----

#' @rdname NextBestMaxGain-class
#' @note Typically, end users will not use the `.DefaultNextBestMaxGain()` function.
#' @export
.DefaultNextBestMaxGain <- function() {
  NextBestMaxGain(0.35, 0.3)
}

# NextBestMaxGainSamples ----

## class ----

#' `NextBestMaxGainSamples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMaxGainSamples`] is the class to find a next best dose with maximum
#' gain value based on a pseudo DLT and efficacy models and DLT and efficacy
#' samples. There are two target probabilities of the occurrence of a DLT that
#' must be specified: target probability to be used during the trial and target
#' probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model and [`ModelEff`]
#' classes.
#'
#' @slot derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples, the target dose that has the probability of the occurrence of
#'   DLT equals to either the `prob_target_drt` or `prob_target_eot`. It must
#'   therefore accept one and only one argument, which is a numeric vector, and
#'   return a number.
#' @slot mg_derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples that give the maximum gain value, the final next best estimate of
#'   the dose that gives the maximum gain value. It must therefore accept one
#'   and only one argument, which is a numeric vector, and return a number.
#'
#' @aliases NextBestMaxGainSamples
#' @export
#'
.NextBestMaxGainSamples <- setClass(
  Class = "NextBestMaxGainSamples",
  slots = c(
    derive = "function",
    mg_derive = "function"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(dose_samples) {
      as.numeric(quantile(dose_samples, prob = 0.3))
    },
    mg_derive = function(dose_samples) {
      as.numeric(quantile(dose_samples, prob = 0.5))
    }
  ),
  contains = "NextBestMaxGain",
  validity = v_next_best_max_gain_samples
)

## constructor ----

#' @rdname NextBestMaxGainSamples-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition in [`NextBestMaxGain`].
#' @param prob_target_eot (`proportion`)\cr see slot definition in [`NextBestMaxGain`].
#' @param derive (`function`)\cr see slot definition.
#' @param mg_derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMaxGainSamples.R
#'
NextBestMaxGainSamples <- function(
  prob_target_drt,
  prob_target_eot,
  derive,
  mg_derive
) {
  .NextBestMaxGainSamples(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot,
    derive = derive,
    mg_derive = mg_derive
  )
}

## default constructor ----

#' @rdname NextBestMaxGainSamples-class
#' @note Typically, end users will not use the `.DefaultNextBestMaxGainSamples()` function.
#' @export
.DefaultNextBestMaxGainSamples <- function() {
  NextBestMaxGainSamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, prob = 0.3))
    },
    mg_derive = function(mg_samples) {
      as.numeric(quantile(mg_samples, prob = 0.5))
    }
  )
}

# NextBestProbMTDLTE ----

## class ----

#' `NextBestProbMTDLTE`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestProbMTDLTE`] is the class of finding a next best dose that selects
#' the dose with the highest probability of having a toxicity rate less or equal
#' to the toxicity target.
#' The dose is determined by calculating the posterior toxicity probability
#' for each dose per iteration and select the maximum dose that has a toxicity
#' probability below or equal to the target. The dose with the highest frequency
#' of being selected as MTD across iterations is the next best dose. Placebo
#' is not considered in the calculation and removed from the dose grid for
#' any calculations.
#'
#' @slot target (`numeric`)\cr the target toxicity probability.
#'
#' @aliases NextBestProbMTDLTE
#' @export
#'
.NextBestProbMTDLTE <- setClass(
  Class = "NextBestProbMTDLTE",
  slots = c(target = "numeric"),
  prototype = prototype(target = 0.3),
  contains = "NextBest",
  validity = v_next_best_prob_mtd_lte
)

## constructor ----

#' @rdname NextBestProbMTDLTE-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestProbMTDLTE.R
#'
NextBestProbMTDLTE <- function(target) {
  .NextBestProbMTDLTE(target = target)
}

## default constructor ----

#' @rdname NextBestProbMTDLTE-class
#' @note Typically, end users will not use the `.DefaultNextBestProbMTDLTE()` function.
#' @export
.DefaultNextBestProbMTDLTE <- function() {
  NextBestProbMTDLTE(target = 0.3)
}

# NextBestProbMTDMinDist ----

## class ----

#' `NextBestProbMTDMinDist`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestProbMTDMinDist`] is the class of finding a next best dose that selects
#' the dose with the highest probability of having a toxicity rate with the
#' smallest distance to the toxicity target.
#' The dose is determined by calculating the posterior toxicity probability
#' for each dose per iteration and select the dose that has the smallest toxicity
#' probability distance to the target. The dose with the highest frequency
#' of being selected as MTD across iterations is the next best dose. Placebo
#' is not considered as the next dose and for that reason not used in
#' calculations. I.e. for placebo the toxicity probability distance to target
#' is not calculated and taken into account for determination of the next dose.
#'
#' @slot target (`numeric`)\cr the target toxicity probability.
#'
#' @aliases NextBestProbMTDMinDist
#' @export
#'
.NextBestProbMTDMinDist <- setClass(
  Class = "NextBestProbMTDMinDist",
  slots = c(target = "numeric"),
  prototype = prototype(target = 0.3),
  contains = "NextBest",
  validity = v_next_best_prob_mtd_min_dist
)

## constructor ----

#' @rdname NextBestProbMTDMinDist-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestProbMTDMinDist.R
#'
NextBestProbMTDMinDist <- function(target) {
  .NextBestProbMTDMinDist(target = target)
}

## default constructor ----

#' @rdname NextBestProbMTDMinDist-class
#' @note Typically, end users will not use the `.DefaultNextBestProbMTDMinDist()` function.
#' @export
.DefaultNextBestProbMTDMinDist <- function() {
  NextBestProbMTDMinDist(target = 0.3)
}

# NextBestOrdinal ----

## class ----

#' `NextBestOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestOrdinal`] is the class for applying a standard `NextBest` rule to
#' the results of an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the toxicity grade to which the `rule` should be
#' applied.
#' @slot rule (`NextBest`)\cr the standard `NextBest` rule to be applied
#'
#' @aliases NextBestOrdinal
#' @export
#'
.NextBestOrdinal <- setClass(
  Class = "NextBestOrdinal",
  slots = c(grade = "numeric", rule = "NextBest"),
  contains = "NextBest",
  validity = v_next_best_ordinal
)

## constructor ----

#' @rdname NextBestOrdinal-class
#'
#' @param grade (`numeric`)\cr see slot definition.
#' @param rule (`NextBest`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestOrdinal.R
#'
NextBestOrdinal <- function(grade, rule) {
  .NextBestOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname NextBestOrdinal-class
#' @note Typically, end users will not use the `.DefaultNextBestOrdinal()` function.
#' @export
.DefaultNextBestOrdinal <- function() {
  NextBestOrdinal(
    grade = 1L,
    rule = NextBestMTD(
      0.25,
      function(mtd_samples) {
        quantile(mtd_samples, probs = 0.25)
      }
    )
  )
}

# Increments ----

## class ----

#' `Increments`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Increments`] is a virtual class for controlling increments, from which all
#' other specific increments classes inherit.
#'
#' @seealso [`IncrementsRelative`], [`IncrementsRelativeDLT`],
#'   [`IncrementsDoseLevels`], [`IncrementsHSRBeta`], [`IncrementsMin`].
#'
#' @aliases Increments
#' @export
#'
setClass(
  Class = "Increments",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname Increments-class
#' @note Typically, end users will not use the `.DefaultIncrements()` function.
#' @export
.DefaultIncrements <- function() {
  stop(paste0(
    "Class Increments cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}


# IncrementsRelative ----

## class ----

#' `IncrementsRelative`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelative`] is the class for increments control based on relative
#' differences in intervals.
#'
#' @slot intervals (`numeric`)\cr a vector with the left bounds of the relevant
#'   intervals. For example, `intervals  = c(0, 50, 100)` specifies three intervals:
#'   \eqn{(0, 50)}, \eqn{[50, 100)} and \eqn{[100, +Inf)}. That means, the right
#'   bound of the intervals are exclusive to the interval and the last interval
#'   goes from the last value to infinity.
#' @slot increments (`numeric`)\cr a vector of the same length with the maximum
#'   allowable relative increments in the `intervals`.
#'
#' @aliases IncrementsRelative
#' @export
#'
.IncrementsRelative <- setClass(
  Class = "IncrementsRelative",
  slots = c(
    intervals = "numeric",
    increments = "numeric"
  ),
  prototype = prototype(
    intervals = c(0, 2),
    increments = c(2, 1)
  ),
  contains = "Increments",
  validity = v_increments_relative
)

## constructor ----

#' @rdname IncrementsRelative-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param increments (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsRelative.R
#'
IncrementsRelative <- function(intervals, increments) {
  .IncrementsRelative(
    intervals = intervals,
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelative-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelative()` function.
#' @export
.DefaultIncrementsRelative <- function() {
  IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
}


# IncrementsRelativeDLT ----

## class ----

#' `IncrementsRelativeDLT`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelativeDLT`] is the class for increments control based on
#' relative differences in terms of DLTs.
#'
#' @slot intervals (`integer`)\cr a vector with the left bounds of the
#'   relevant DLT intervals. For example, `intervals  = c(0, 1, 3)` specifies
#'   three intervals (sets of DLTs: first, 0 DLT; second 1 or 2 DLTs; and the third
#'   one, at least 3 DLTs. That means, the right bound of the intervals are
#'   exclusive to the interval and the last interval goes from the last value to
#'   infinity.
#' @slot increments (`numeric`)\cr a vector of maximum allowable relative
#'   increments corresponding to `intervals`. IT must be of the same length
#'   as the length of `intervals`.
#'
#' @note This considers all DLTs across all cohorts observed so far.
#'
#' @seealso [IncrementsRelativeDLTCurrent] which only considers the DLTs
#'   in the current cohort.
#'
#' @aliases IncrementsRelativeDLT
#' @export
#'
.IncrementsRelativeDLT <- setClass(
  Class = "IncrementsRelativeDLT",
  slots = representation(
    intervals = "integer",
    increments = "numeric"
  ),
  prototype = prototype(
    intervals = c(0L, 1L),
    increments = c(2, 1)
  ),
  contains = "Increments",
  validity = v_increments_relative_dlt
)

## constructor ----

#' @rdname IncrementsRelativeDLT-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param increments (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsRelativeDLT.R
#'
IncrementsRelativeDLT <- function(intervals, increments) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  assert_numeric(increments, any.missing = FALSE, lower = 0)

  .IncrementsRelativeDLT(
    intervals = as.integer(intervals),
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelativeDLT-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeDLT()` function.
#' @export
.DefaultIncrementsRelativeDLT <- function() {
  IncrementsRelativeDLT(intervals = c(0L, 1L, 3L), increments = c(1, 0.33, 0.2))
}

# IncrementsRelativeDLTCurrent ----

## class ----

#' `IncrementsRelativeDLTCurrent`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsRelativeDLTCurrent`] is the class for increments control based on
#' relative differences and current DLTs. The class is based on the number of
#' DLTs observed in the current cohort, but not cumulatively over all cohorts
#' so far.
#'
#' @seealso [IncrementsRelativeDLT].
#'
#' @aliases IncrementsRelativeDLTCurrent
#' @export
#'
.IncrementsRelativeDLTCurrent <- setClass(
  Class = "IncrementsRelativeDLTCurrent",
  contains = "IncrementsRelativeDLT"
)

## constructor ----

#' @rdname IncrementsRelativeDLTCurrent-class
#'
#' @inheritParams IncrementsRelativeDLT
#'
#' @export
#' @example examples/Rules-class-IncrementsRelativeDLTCurrent.R
#'
IncrementsRelativeDLTCurrent <- function(
  intervals = c(0L, 1L),
  increments = c(2L, 1L)
) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  assert_numeric(increments, any.missing = FALSE, lower = 0)

  .IncrementsRelativeDLTCurrent(
    intervals = as.integer(intervals),
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelativeDLTCurrent-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeDLTCurrent()` function.
#' @export
.DefaultIncrementsRelativeDLTCurrent <- function() {
  # nolint
  IncrementsRelativeDLTCurrent(
    intervals = c(0L, 1L, 3L),
    increments = c(1, 0.33, 0.2)
  )
}

# IncrementsRelativeParts ----

## class ----

#' `IncrementsRelativeParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelativeParts`] is the class for increments control based on
#' relative differences in intervals, with special rules for part 1 and
#' beginning of part 2.
#'
#' @details This class works only in conjunction with [`DataParts`] objects. If
#' part 2 will just be started in the next cohort, then the next maximum dose
#' will be either `dlt_start` (e.g. -1) shift of the last part 1 dose in case
#' of a DLT in part 1, or `clean_start` shift (e.g. -1) in case of no DLTs in
#' part 1, given that `clean_start <= 0` (see description of `clean_start`
#' slot for more details). If part 1 will still be on in the next cohort,
#' then the next dose level will be the next higher dose level in the
#' `part1Ladder` slot of the data object. If part 2 has been started before,
#' the usual relative increment rules apply, see [`IncrementsRelative`].
#'
#' @slot dlt_start (`integer`)\cr a scalar, the dose level increment for starting
#'   part 2 in case of at least one DLT event in part 1.
#' @slot clean_start (`integer`)\cr a scalar, the dose level increment for
#'   starting part 2 in case of no DLTs in part 1. If `clean_start <= 0`,
#'   then the part 1 ladder will be used to find the maximum next dose.
#'   Otherwise, the relative increment rules will be applied to find the next
#'   maximum dose level.
#'
#' @note We require that `clean_start >= dlt_start`. However, this precondition
#'   is not a prerequisite for any function (except of the class' validation
#'   function) that works with objects of this class. It is rather motivated by
#'   the semantics. That is, if we observe a DLT in part 1, we cannot be more
#'   aggressive than in case of a clean part 1 without DLT.
#'
#' @aliases IncrementsRelativeParts
#' @export
#'
.IncrementsRelativeParts <- setClass(
  Class = "IncrementsRelativeParts",
  slots = representation(
    dlt_start = "integer",
    clean_start = "integer"
  ),
  prototype = prototype(
    dlt_start = -1L,
    clean_start = 1L
  ),
  contains = "IncrementsRelative",
  validity = v_increments_relative_parts
)

## constructor ----

#' @rdname IncrementsRelativeParts-class
#'
#' @param dlt_start (`count`)\cr see slot definition.
#' @param clean_start (`count`)\cr see slot definition.
#' @inheritDotParams IncrementsRelative
#'
#' @export
#' @example examples/Rules-class-IncrementsRelative-DataParts.R
#'
IncrementsRelativeParts <- function(dlt_start, clean_start, ...) {
  assert_integerish(dlt_start)
  assert_integerish(clean_start)

  .IncrementsRelativeParts(
    dlt_start = as.integer(dlt_start),
    clean_start = as.integer(clean_start),
    ...
  )
}

## default constructor ----

#' @rdname IncrementsRelativeParts-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeParts()` function.
#' @export
.DefaultIncrementsRelativeParts <- function() {
  IncrementsRelativeParts(dlt_start = 0L, clean_start = 1L)
}

# IncrementsDoseLevels ----

## class ----

#' `IncrementsDoseLevels`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsDoseLevels`] is the class for increments control based on the
#' number of dose levels.
#'
#' @slot levels (`count`)\cr maximum number of dose levels to increment for
#'   the next dose. It defaults to 1, which means that no dose skipping is
#'   allowed, i.e. the next dose can be maximum one level higher than the current
#'   base dose. The current base dose level is the dose level used to increment
#'   from (see `basis_level` parameter).
#' @slot basis_level (`string`)\cr defines the current base dose level. It can
#'   take one out of two possible values: `last` or `max`.
#'   If `last` is specified (default), the current base dose level is set to the
#'   last dose given. If `max` is specified, then the current base dose level is
#'   set to the maximum dose level given.
#'
#' @aliases IncrementsDoseLevels
#' @export
#'
.IncrementsDoseLevels <- setClass(
  Class = "IncrementsDoseLevels",
  slots = representation(
    levels = "integer",
    basis_level = "character"
  ),
  prototype = prototype(
    levels = 1L,
    basis_level = "last"
  ),
  contains = "Increments",
  validity = v_increments_dose_levels
)

## constructor ----

#' @rdname IncrementsDoseLevels-class
#'
#' @param levels (`count`)\cr see slot definition.
#' @param basis_level (`string`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsDoseLevels.R
#'
IncrementsDoseLevels <- function(levels = 1L, basis_level = "last") {
  assert_count(levels, positive = TRUE)
  assert_string(basis_level)
  assert_subset(basis_level, c("last", "max"))

  .IncrementsDoseLevels(
    levels = as.integer(levels),
    basis_level = basis_level
  )
}

## default constructor ----

#' @rdname IncrementsDoseLevels-class
#' @note Typically, end users will not use the `.DefaultIncrementsDoseLevels()` function.
#' @export
.DefaultIncrementsDoseLevels <- function() {
  IncrementsDoseLevels(levels = 2L, basis_level = "last")
}

# IncrementsHSRBeta ----

## class ----

#' `IncrementsHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsHSRBeta`] is a class for limiting further increments using
#' a Hard Safety Rule based on the Bin-Beta model.
#' Increment control is based on the number of observed DLTs and number of
#' subjects at each dose level. The probability of toxicity is calculated
#' using a Bin-Beta model with prior (a,b). If the probability exceeds
#' the threshold for a given dose, that dose and all doses above are excluded
#' from further escalation.
#' This is a hard safety rule that limits further escalation based on the
#' observed data per dose level, independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity, except
#'   0 or 1.
#' @slot prob (`proportion`)\cr the threshold probability (except 0 or 1) for
#'   a dose being toxic.
#' @slot a (`number`)\cr shape parameter \eqn{a > 0} of probability distribution
#'   Beta (a,b).
#' @slot b (`number`)\cr shape parameter \eqn{b > 0} of probability distribution
#'   Beta (a,b).
#'
#' @aliases IncrementsHSRBeta
#' @export
#'
.IncrementsHSRBeta <- setClass(
  Class = "IncrementsHSRBeta",
  slots = c(
    target = "numeric",
    prob = "numeric",
    a = "numeric",
    b = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  ),
  contains = "Increments",
  validity = v_increments_hsr_beta
)

## constructor ----

#' @rdname IncrementsHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#'
#' @example examples/Rules-class-IncrementsHSRBeta.R
#' @export
#'
IncrementsHSRBeta <- function(target = 0.3, prob = 0.95, a = 1, b = 1) {
  .IncrementsHSRBeta(
    target = target,
    prob = prob,
    a = a,
    b = b
  )
}

## default constructor ----

#' @rdname IncrementsHSRBeta-class
#' @note Typically, end users will not use the `.DefaultIncrementsHSRBeta()` function.
#' @export
.DefaultIncrementsHSRBeta <- function() {
  IncrementsHSRBeta(target = 0.3, prob = 0.95)
}

# IncrementsMin ----

## class ----

#' `IncrementsMin`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsMin`] is the class that combines multiple increment rules with
#' the `minimum` operation. Slot `increments_list` contains all increment rules,
#' which are itself the objects of class [`Increments`]. The minimum of these
#' individual increments is taken to give the final maximum increment.
#'
#' @slot increments_list (`list`)\cr list with increment rules.
#'
#' @aliases IncrementsMin
#' @export
#'
.IncrementsMin <- setClass(
  Class = "IncrementsMin",
  slots = c(increments_list = "list"),
  prototype = prototype(
    increments_list = list(
      IncrementsRelativeDLT(intervals = c(0L, 1L), increments = c(2, 1)),
      IncrementsRelative(intervals = c(0, 2), increments = c(2, 1))
    )
  ),
  contains = "Increments",
  validity = v_increments_min
)

## constructor ----

#' @rdname IncrementsMin-class
#'
#' @param increments_list (`list`)\cr see slot definition.
#'
#' @example examples/Rules-class-IncrementsMin.R
#' @export
#'
IncrementsMin <- function(increments_list) {
  .IncrementsMin(increments_list = increments_list)
}
## default constructor ----

#' @rdname IncrementsMin-class
#' @note Typically, end users will not use the `.DefaultIncrementsMin()` function.
#' @export
.DefaultIncrementsMin <- function() {
  IncrementsMin(
    increments_list = list(
      IncrementsRelativeDLT(
        intervals = c(0, 1, 3),
        increments = c(1, 0.33, 0.2)
      ),
      IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
    )
  )
}

# IncrementsOrdinal ----

## class ----

#' `IncrementsOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsOrdinal`] is the class for applying a standard `Increments` rule to
#' the results of an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the toxicity grade to which the `rule` should be
#' applied.
#' @slot rule (`Increments`)\cr the standard `Increments` rule to be applied
#'
#' @aliases IncrementsOrdinal
#' @export
#'
.IncrementsOrdinal <- setClass(
  Class = "IncrementsOrdinal",
  slots = c(grade = "numeric", rule = "Increments"),
  contains = "Increments",
  validity = v_increments_ordinal
)

## constructor ----

#' @rdname IncrementsOrdinal-class
#'
#' @param grade (`numeric`)\cr see slot definition.
#' @param rule (`Increments`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-IncrementsOrdinal.R
#'
IncrementsOrdinal <- function(grade, rule) {
  .IncrementsOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname IncrementsOrdinal-class
#' @note Typically, end users will not use the `.DefaultIncrementsOrdinal()` function.
#' @export
.DefaultIncrementsOrdinal <- function() {
  IncrementsOrdinal(
    grade = 1L,
    rule = IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
  )
}

# IncrementsMaxToxProb ----

## class ----

#' `IncrementsMaxToxProb`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsMaxToxProb`] is the class for increments control based on
#' probability of toxicity
#'
#' @slot prob (`numeric`)\cr See Usage Notes below.
#'
#' @section Usage Notes:
#' For binary models, `prob` should be a scalar probability.
#'
#' For ordinal models, `prob` should be a named vector containing the maximum
#' permissible probability of toxicity by grade.  The names should match the
#' names of the `yCategories` slot of the associated `DataOrdinal` object.
#'
#' @aliases IncrementsMaxToxProb
#' @export
#'
.IncrementsMaxToxProb <- setClass(
  Class = "IncrementsMaxToxProb",
  slots = c(
    prob = "numeric"
  ),
  prototype = prototype(
    prob = c("DLAE" = 0.2, "DLT" = 0.05)
  ),
  contains = "Increments",
  validity = v_increments_maxtoxprob
)

## constructor ----

#' @rdname IncrementsMaxToxProb-class
#'
#' @param prob (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsMaxToxProb.R
#'
IncrementsMaxToxProb <- function(prob) {
  .IncrementsMaxToxProb(
    prob = prob
  )
}

## default constructor ----

#' @rdname IncrementsMaxToxProb-class
#' @note Typically, end users will not use the `.DefaultIncrementsMaxToxProb()` function.
#' @export
.DefaultIncrementsMaxToxProb <- function() {
  IncrementsMaxToxProb(prob = c("DLAE" = 0.2, "DLT" = 0.05))
}

# Stopping ----

## class ----

#' `Stopping`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Stopping`] is a class for stopping rules.
#'
#' @slot report_label (`string`)\cr a label for the stopping report. The meaning
#'   of this parameter is twofold. If it is equal to `NA_character_` (default),
#'   the `report_label` will not be used in the report at all. Otherwise, if it
#'   is specified as an empty character (i.e. `character(0)`) in a user constructor,
#'   then a default, class-specific label will be created for this slot.
#'   Finally, for the remaining cases, a user can provide a custom label.
#'
#' @seealso [`StoppingList`], [`StoppingCohortsNearDose`], [`StoppingPatientsNearDose`],
#'   [`StoppingMinCohorts`], [`StoppingMinPatients`], [`StoppingTargetProb`],
#'   [`StoppingMTDdistribution`], [`StoppingTargetBiomarker`], [`StoppingHighestDose`]
#'   [`StoppingMTDCV`], [`StoppingLowestDoseHSRBeta`], [`StoppingSpecificDose`].
#'
#' @aliases Stopping
#' @export
#'
setClass(
  Class = "Stopping",
  contains = "CrmPackClass",
  slots = c(report_label = "character"),
  prototype = prototype(report_label = character(0))
)


## default constructor ----

#' @rdname CohortSize-class
#' @note Typically, end users will not use the `DefaultCohortSize()` function.
#' @export
.DefaultCohortSize <- function() {
  stop(paste0(
    "Class CohortSize should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# StoppingMissingDose ----

## class ----

#' `StoppingMissingDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingMissingDose`] is the class for stopping based on NA returned by
#'  next best dose.
#'
#' @aliases StoppingMissingDose
#' @export
#'
.StoppingMissingDose <- setClass(
  Class = "StoppingMissingDose",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingMissingDose-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#' @example examples/Rules-class-StoppingMissingDose.R
#' @export
#'
StoppingMissingDose <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("Stopped because of missing dose")
  )

  .StoppingMissingDose(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingMissingDose-class
#' @note Typically, end users will not use the `.DefaultStoppingMissingDose()` function.
#' @export
#'
.DefaultStoppingMissingDose <- function() {
  StoppingMissingDose()
}

# StoppingCohortsNearDose ----

## class ----

#' `StoppingCohortsNearDose`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingCohortsNearDose`] is the class for stopping based on number of
#' cohorts near to next best dose.
#'
#'
#' @slot nCohorts (`number`)\cr number of required cohorts.
#' @slot percentage (`number`)\cr percentage (between and including 0 and 100)
#'   within the next best dose the cohorts must lie.
#'
#' @aliases StoppingCohortsNearDose
#' @export
#'
.StoppingCohortsNearDose <- setClass(
  Class = "StoppingCohortsNearDose",
  slots = c(
    nCohorts = "integer",
    percentage = "numeric"
  ),
  prototype = prototype(
    nCohorts = 2L,
    percentage = 50
  ),
  contains = "Stopping",
  validity = v_stopping_cohorts_near_dose
)

## constructor ----

#' @rdname StoppingCohortsNearDose-class
#'
#' @param nCohorts (`number`)\cr see slot definition.
#' @param percentage (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingCohortsNearDose.R
#' @export
#'
StoppingCohortsNearDose <- function(
  nCohorts = 2L,
  percentage = 50,
  report_label = NA_character_
) {
  assert_count(nCohorts, positive = TRUE)
  assert_numeric(percentage, lower = 0)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste(
      "\u2265",
      nCohorts,
      "cohorts dosed in",
      percentage,
      "% dose range around NBD"
    )
  )

  .StoppingCohortsNearDose(
    nCohorts = as.integer(nCohorts),
    percentage = percentage,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingCohortsNearDose-class
#' @note Typically, end users will not use the `.DefaultStoppingCohortsNearDose()` function.
#' @export
.DefaultStoppingCohortsNearDose <- function() {
  # nolint
  StoppingCohortsNearDose(
    nCohorts = 3L,
    percentage = 0.2
  )
}


# StoppingPatientsNearDose ----

## class ----

#' `StoppingPatientsNearDose`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingPatientsNearDose`] is the class for stopping based on number of
#' patients near to next best dose.
#'
#' @slot nPatients (`number`)\cr number of required patients.
#' @slot percentage (`number`)\cr percentage (between and including 0 and 100)
#'   within the next best dose the patients must lie.
#'
#' @aliases StoppingPatientsNearDose
#' @export
#'
.StoppingPatientsNearDose <- setClass(
  Class = "StoppingPatientsNearDose",
  slots = c(
    nPatients = "integer",
    percentage = "numeric"
  ),
  prototype = prototype(
    nPatients = 10L,
    percentage = 50
  ),
  contains = "Stopping",
  validity = v_stopping_patients_near_dose
)

## constructor ----

#' @rdname StoppingPatientsNearDose-class
#'
#' @param nPatients (`number`)\cr see slot definition.
#' @param percentage (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingPatientsNearDose.R
#' @export
#'
StoppingPatientsNearDose <- function(
  nPatients = 10L,
  percentage = 50,
  report_label = NA_character_
) {
  assert_count(nPatients, positive = TRUE)
  assert_number(percentage, lower = 0, upper = 100)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste(
      "\u2265",
      nPatients,
      "patients dosed in",
      percentage,
      "% dose range around NBD"
    )
  )

  .StoppingPatientsNearDose(
    nPatients = as.integer(nPatients),
    percentage = percentage,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingPatientsNearDose-class
#' @note Typically, end users will not use the `.DefaultStoppingPatientsNearDose()` function.
#' @export
.DefaultStoppingPatientsNearDose <- function() {
  # nolint
  StoppingPatientsNearDose(
    nPatients = 9L,
    percentage = 20,
    report_label = NA_character_
  )
}

# StoppingMinCohorts ----

## class ----

#' `StoppingMinCohorts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMinCohorts`] is the class for stopping based on minimum number of
#' cohorts.
#'
#' @slot nCohorts (`number`)\cr minimum required number of cohorts.
#'
#' @aliases StoppingMinCohorts
#' @export
#'
.StoppingMinCohorts <- setClass(
  Class = "StoppingMinCohorts",
  slots = c(nCohorts = "integer"),
  prototype = prototype(nCohorts = 2L),
  contains = "Stopping",
  validity = v_stopping_min_cohorts
)

## constructor ----

#' @rdname StoppingMinCohorts-class
#'
#' @param nCohorts (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMinCohorts.R
#' @export
#'
StoppingMinCohorts <- function(nCohorts = 2L, report_label = NA_character_) {
  assert_count(nCohorts, positive = TRUE)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nCohorts, "cohorts dosed")
  )

  .StoppingMinCohorts(
    nCohorts = as.integer(nCohorts),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMinCohorts-class
#' @note Typically, end users will not use the `.DefaultStoppingMinCohorts()` function.
#' @export
.DefaultStoppingMinCohorts <- function() {
  StoppingMinCohorts(
    nCohorts = 6L
  )
}

# StoppingMinPatients ----

## class ----

#' `StoppingMinPatients`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMinPatients`] is the class for stopping based on minimum number of
#' patients
#'
#' @slot nPatients (`number`)\cr minimum allowed number of patients.
#'
#' @aliases StoppingMinPatients
#' @export
#'
.StoppingMinPatients <- setClass(
  Class = "StoppingMinPatients",
  slots = c(nPatients = "integer"),
  prototype = prototype(nPatients = 20L),
  contains = "Stopping",
  validity = v_stopping_min_patients
)

## constructor ----

#' @rdname StoppingMinPatients-class
#'
#' @param nPatients (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMinPatients.R
#' @export
#'
StoppingMinPatients <- function(nPatients = 20L, report_label = NA_character_) {
  assert_count(nPatients, positive = TRUE)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nPatients, "patients dosed")
  )

  .StoppingMinPatients(
    nPatients = as.integer(nPatients),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMinPatients-class
#' @note Typically, end users will not use the `.DefaultStoppingMinPatients()` function.
#' @export
.DefaultStoppingMinPatients <- function() {
  StoppingMinPatients(
    nPatients = 20L
  )
}

# StoppingTargetProb ----

## class ----

#' `StoppingTargetProb`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTargetProb`] is the class for stopping based on the probability of
#' the DLT rate being in the target toxicity interval.
#'
#' @slot target (`number`)\cr the target toxicity interval, e.g. `c(0.2, 0.35)`.
#' @slot prob (`proportion`)\cr required target toxicity probability (except 0 or 1)
#'   for reaching sufficient precision.
#'
#' @aliases StoppingTargetProb
#' @export
#'
.StoppingTargetProb <- setClass(
  Class = "StoppingTargetProb",
  slots = c(
    target = "numeric",
    prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.2, 0.35),
    prob = 0.4
  ),
  contains = "Stopping",
  validity = v_stopping_target_prob
)

## constructor ----

#' @rdname StoppingTargetProb-class
#'
#' @param target (`number`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingTargetProb.R
#' @export
#'
StoppingTargetProb <- function(
  target = c(0.2, 0.35),
  prob = 0.4,
  report_label = NA_character_
) {
  assert_numeric(target, len = 2)
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0(
      "P(",
      target[1],
      " \u2264 prob(DLE | NBD) \u2264 ",
      target[2],
      ") \u2265 ",
      prob
    )
  )

  .StoppingTargetProb(
    target = target,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTargetProb-class
#' @note Typically, end users will not use the `.DefaultStoppingTargetProb()` function.
#' @export
.DefaultStoppingTargetProb <- function() {
  StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
}

# StoppingMTDdistribution ----

## class ----

#' `StoppingMTDdistribution`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMTDdistribution`] is the class for stopping based on the posterior
#' distribution of the MTD. It is used for the cases where the stopping occurs
#' when the probability of `MTD > thresh * next_dose` is greater than or equal
#' to `prob`, where the `next_dose` is the recommended next best dose.
#' Here, the MTD is defined as the dose that reaches a specific `target`
#' probability of the occurrence of a DLT.
#'
#' @slot target (`proportion`)\cr the target toxicity probability (except 0 or 1)
#'   defining the MTD.
#' @slot thresh (`proportion`)\cr the threshold (except 0 or 1) relative to the
#'   recommended next best dose.
#' @slot prob (`proportion`)\cr required minimum probability, except 0 or 1.
#'
#' @aliases StoppingMTDdistribution
#' @export
#'
.StoppingMTDdistribution <- setClass(
  Class = "StoppingMTDdistribution",
  slots = c(
    target = "numeric",
    thresh = "numeric",
    prob = "numeric"
  ),
  prototype = prototype(
    target = 0.33,
    thresh = 0.5,
    prob = 0.9
  ),
  contains = "Stopping",
  validity = v_stopping_mtd_distribution
)

## constructor ----

#' @rdname StoppingMTDdistribution-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param thresh (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMTDdistribution.R
#' @export
#'
StoppingMTDdistribution <- function(
  target = 0.33,
  thresh = 0.5,
  prob = 0.9,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P(MTD > ", thresh, " * NBD | P(DLE) = ", target, ") \u2265 ", prob)
  )

  .StoppingMTDdistribution(
    target = target,
    thresh = thresh,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMTDdistribution-class
#' @note Typically, end users will not use the `.DefaultStoppingMTDDistribution()` function.
#' @export
.DefaultStoppingMTDdistribution <- function() {
  StoppingMTDdistribution(
    target = 0.33,
    thresh = 0.5,
    prob = 0.9
  )
}

# StoppingMTDCV ----

## class ----

#' `StoppingMTDCV`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingMTDCV`] is a class for stopping rule based on precision of MTD
#' which is calculated as the coefficient of variation (CV) of the MTD.
#' Here, the MTD is defined as the dose that reaches a specific `target`
#' probability of the occurrence of a DLT.
#'
#' @slot target (`proportion`)\cr toxicity target of MTD (except 0 or 1).
#' @slot thresh_cv (`number`)\cr threshold (percentage > 0) for CV to be
#'   considered accurate enough to stop the trial. The stopping occurs when the
#'   CV is less than or equal to `tresh_cv`.
#'
#' @aliases StoppingMTDCV
#' @export
#'
.StoppingMTDCV <- setClass(
  Class = "StoppingMTDCV",
  slots = c(
    target = "numeric",
    thresh_cv = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    thresh_cv = 40
  ),
  contains = "Stopping",
  validity = v_stopping_mtd_cv
)

## constructor ----

#' @rdname StoppingMTDCV-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param thresh_cv (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingMTDCV.R
#'
StoppingMTDCV <- function(
  target = 0.3,
  thresh_cv = 40,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("CV(MTD) >", target)
  )

  .StoppingMTDCV(
    target = target,
    thresh_cv = thresh_cv,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMTDCV-class
#' @note Typically, end users will not use the `.DefaultStoppingMTDCV()` function.
#'
#' @export
.DefaultStoppingMTDCV <- function() {
  StoppingMTDCV(
    target = 0.3,
    thresh_cv = 40
  )
}

# StoppingLowestDoseHSRBeta ----

## class ----

#' `StoppingLowestDoseHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingLowestDoseHSRBeta`] is a class for stopping based on a Hard Safety
#' Rule using the Beta posterior distribution with Beta(a,b) prior and a
#' Bin-Beta model based on the observed data at the lowest dose level.
#' The rule is triggered when the first dose is considered to be toxic
#' (i.e. above threshold probability) based on the observed data at the
#' lowest dose level and a Beta(a,b) prior distribution.
#' The default prior is Beta(1,1).
#' In case that placebo is used, the rule is evaluated at the second dose of the
#' dose grid, i.e. at the lowest non-placebo dose.
#'
#' @note This stopping rule is independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity.
#' @slot prob (`proportion`)\cr the threshold probability for the lowest dose
#'   being toxic.
#' @slot a (`number`)\cr shape parameter \eqn{a > 0} of probability distribution
#'   Beta (a,b).
#' @slot b (`number`)\cr shape parameter \eqn{b > 0} of probability distribution
#'   Beta (a,b).
#'
#' @aliases StoppingLowestDoseHSRBeta
#' @export
#'
.StoppingLowestDoseHSRBeta <- setClass(
  Class = "StoppingLowestDoseHSRBeta",
  slots = c(
    target = "numeric",
    prob = "numeric",
    a = "numeric",
    b = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  ),
  contains = "Stopping",
  validity = v_increments_hsr_beta
)

## constructor ----

#' @rdname StoppingLowestDoseHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingLowestDoseHSRBeta.R
#'
StoppingLowestDoseHSRBeta <- function(
  target = 0.3,
  prob = 0.95,
  a = 1,
  b = 1,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P\u03B2(lowest dose > P(DLE) = ", target, ") > ", prob)
  )

  .StoppingLowestDoseHSRBeta(
    target = target,
    prob = prob,
    a = a,
    b = b,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingLowestDoseHSRBeta-class
#' @note Typically, end users will not use the `.DefaultStoppingLowestDoseHSRBeta()` function.
#' @export
.DefaultStoppingLowestDoseHSRBeta <- function() {
  # nolint
  StoppingLowestDoseHSRBeta(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  )
}

# StoppingTargetBiomarker ----

## class ----

#' `StoppingTargetBiomarker`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTargetBiomarker`] is a class for stopping based on probability of
#' target biomarker.
#'
#' @slot target (`numeric`)\cr the biomarker target range that needs to be
#'   reached. For example, `target = c(0.8, 1.0)` with `is_relative = TRUE`
#'   means that we target a dose with at least 80% of maximum biomarker level.
#' @slot is_relative (`flag`)\cr is target relative? If it so (default), then
#'   the `target` is interpreted relative to the maximum, so it must be a
#'   probability range. Otherwise, the `target` is interpreted as absolute
#'   biomarker range.
#' @slot prob (`proportion`)\cr required target probability (except 0 or 1) for
#'   reaching sufficient precision.
#'
#' @aliases StoppingTargetBiomarker
#' @export
#'
.StoppingTargetBiomarker <- setClass(
  Class = "StoppingTargetBiomarker",
  slots = c(
    target = "numeric",
    is_relative = "logical",
    prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.9, 1),
    is_relative = TRUE,
    prob = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_target_biomarker
)

## constructor ----

#' @rdname StoppingTargetBiomarker-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param is_relative (`flag`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingTargetBiomarker.R
#'
StoppingTargetBiomarker <- function(
  target = c(0.9, 1),
  prob = 0.3,
  is_relative = TRUE,
  report_label = NA_character_
) {
  assert_numeric(target, len = 2)
  assert_flag(is_relative)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0(
      "P(",
      target[1],
      " \u2264 ",
      "Biomarker \u2264 ",
      target[2],
      ") \u2265 ",
      prob,
      ifelse(is_relative, " (relative)", " (absolute)")
    )
  )

  .StoppingTargetBiomarker(
    target = target,
    is_relative = is_relative,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTargetBiomarker-class
#' @note Typically, end users will not use the `.DefaultStoppingTargetBiomarker()` function.
#' @export
.DefaultStoppingTargetBiomarker <- function() {
  StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5,
    is_relative = TRUE
  )
}

# StoppingSpecificDose ----

## class ----

#' `StoppingSpecificDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingSpecificDose`] is the class for testing a stopping rule at specific
#' dose of the dose grid and not at the next best dose.
#'
#' @slot rule (`Stopping`)\cr a stopping rule available in this package.
#' @slot dose (`positive_number`)\cr a dose that is defined as part of the dose
#'   grid of the data.
#'
#' @aliases StoppingSpecificDose
#' @export
#'
.StoppingSpecificDose <- setClass(
  Class = "StoppingSpecificDose",
  slots = c(
    rule = "Stopping",
    dose = "positive_number"
  ),
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingSpecificDose-class
#'
#' @param rule (`Stopping`)\cr see slot definition.
#' @param dose (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`) \cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingSpecificDose.R
#'
StoppingSpecificDose <- function(
  rule = StoppingTargetProb(target = c(0, 0.3), prob = 0.8),
  dose = 80,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("Dose ", dose, " used for testing a stopping rule")
  )

  .StoppingSpecificDose(
    rule = rule,
    dose = positive_number(dose),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingSpecificDose-class
#' @note Typically, end users will not use the `.DefaultStoppingSpecificDose()` function.
#' @export
.DefaultStoppingSpecificDose <- function() {
  StoppingSpecificDose(
    rule = StoppingTargetProb(target = c(0, 0.3), prob = 0.8),
    dose = positive_number(80)
  )
}

# StoppingHighestDose ----

## class ----

#' `StoppingHighestDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingHighestDose`] is the class for stopping based on the highest dose.
#' That is, the stopping occurs when the highest dose is reached.
#'
#' @aliases StoppingHighestDose
#' @export
#'
.StoppingHighestDose <- setClass(
  Class = "StoppingHighestDose",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingHighestDose-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingHighestDose.R
#'
StoppingHighestDose <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    "NBD is the highest dose"
  )

  .StoppingHighestDose(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingHighestDose-class
#' @note Typically, end users will not use the `.DefaultStoppingHighestDose()` function.
#' @export
.DefaultStoppingHighestDose <- function() {
  StoppingHighestDose()
}

# StoppingTDCIRatio ----

## class ----

#' `StoppingTDCIRatio`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTDCIRatio`] is the class for testing a stopping rule that is based
#' on a target ratio of the 95% credibility interval. Specifically, this is the
#' ratio of the upper to the lower bound of the 95% credibility interval's
#' estimate of the target dose (i.e. a dose that corresponds to a given target
#' probability of the occurrence of a DLT `prob_target`).
#'
#' @slot target_ratio (`numeric`)\cr target for the ratio of the 95% credibility
#'   interval's estimate, that is required to stop a trial.
#' @slot prob_target (`proportion`)\cr the target probability of the occurrence
#'   of a DLT.
#'
#' @aliases StoppingTDCIRatio
#' @export
#'
.StoppingTDCIRatio <- setClass(
  Class = "StoppingTDCIRatio",
  slots = c(
    target_ratio = "numeric",
    prob_target = "numeric"
  ),
  prototype = prototype(
    target_ratio = 5,
    prob_target = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_tdci_ratio
)

## constructor ----

#' @rdname StoppingTDCIRatio-class
#'
#' @param target_ratio (`numeric`)\cr see slot definition.
#' @param prob_target (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingTDCIRatio.R
#'
StoppingTDCIRatio <- function(
  target_ratio = 5,
  prob_target = 0.3,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("TD", target_ratio, "for", prob_target, "target prob")
  )

  .StoppingTDCIRatio(
    target_ratio = target_ratio,
    prob_target = prob_target,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTDCIRatio-class
#' @note Typically, end users will not use the `.DefaultStoppingTDCIRatio()` function.
#' @export
.DefaultStoppingTDCIRatio <- function() {
  StoppingTDCIRatio(
    target_ratio = 5,
    prob_target = 0.3
  )
}

# StoppingMaxGainCIRatio ----

## class ----

#' `StoppingMaxGainCIRatio`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMaxGainCIRatio`] is the class for testing a stopping rule that is based
#' on a target ratio of the 95% credibility interval. Specifically, this is the
#' ratio of the upper to the lower bound of the 95% credibility interval's
#' estimate of the:
#' (1) target dose (i.e. a dose that corresponds to a given target
#' probability of the occurrence of a DLT `prob_target`), or
#' (2) max gain dose (i.e. a dose which gives the maximum gain),
#' depending on which one out of these two is smaller.
#'
#' @slot target_ratio (`numeric`)\cr target for the ratio of the 95% credibility
#'   interval's estimate, that is required to stop a trial.
#' @slot prob_target (`proportion`)\cr the target probability of the occurrence
#'   of a DLT.
#'
#' @aliases StoppingMaxGainCIRatio
#' @export
#'
.StoppingMaxGainCIRatio <- setClass(
  Class = "StoppingMaxGainCIRatio",
  slots = c(
    target_ratio = "numeric",
    prob_target = "numeric"
  ),
  prototype = prototype(
    target_ratio = 5,
    prob_target = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_tdci_ratio
)

## constructor ----

#' @rdname StoppingMaxGainCIRatio-class
#'
#' @param target_ratio (`numeric`)\cr see slot definition.
#' @param prob_target (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingMaxGainCIRatio.R
#'
StoppingMaxGainCIRatio <- function(
  target_ratio = 5,
  prob_target = 0.3,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("GStar", target_ratio, "for", prob_target, "target prob")
  )

  .StoppingMaxGainCIRatio(
    target_ratio = target_ratio,
    prob_target = prob_target,
    report_label = report_label
  )
}


## default constructor ----

#' @rdname StoppingMaxGainCIRatio-class
#' @examples
#' .DefaultStoppingMaxGainCIRatio()
#' @export
.DefaultStoppingMaxGainCIRatio <- function() {
  StoppingMaxGainCIRatio(
    target_ratio = 5,
    prob_target = 0.3
  )
}

# StoppingList ----

## class ----

#' `StoppingList`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingList`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' The `summary` slot stores a function that takes a logical vector of the size
#' of `stop_list` and returns a single logical value. For example, if the function
#' `all` is specified as a `summary` function, then that all stopping rules
#' defined in `stop_list` must be satisfied in order the result of this rule to
#' be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot summary (`function`)\cr a summary function to combine the results of
#'   the stopping rules into a single result.
#'
#' @aliases StoppingList
#' @export
#'
.StoppingList <- setClass(
  Class = "StoppingList",
  slots = c(
    stop_list = "list",
    summary = "function"
  ),
  prototype = prototype(
    stop_list = list(StoppingMinPatients(50), StoppingMinCohorts(5)),
    summary = all
  ),
  contains = "Stopping",
  validity = v_stopping_list
)

## constructor ----

#' @rdname StoppingList-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param summary (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingList.R
#'
StoppingList <- function(stop_list, summary) {
  .StoppingList(
    stop_list = stop_list,
    summary = summary
  )
}

## default constructor ----

#' @rdname StoppingList-class
#' @note Typically, end users will not use the `.DefaultStoppingList()` function.
#' @export
.DefaultStoppingList <- function() {
  StoppingList(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    ),
    summary = any
  )
}

# StoppingAll ----

## class ----

#' `StoppingAll`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingAll`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' All single stopping rules must be satisfied in order the result of this rule
#' to be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot report_label label for reporting
#' @aliases StoppingAll
#' @export
#'
.StoppingAll <- setClass(
  Class = "StoppingAll",
  slots = c(
    stop_list = "list"
  ),
  prototype = prototype(
    stop_list = list(
      StoppingMinPatients(50),
      StoppingMinCohorts(5)
    )
  ),
  contains = "Stopping",
  validity = v_stopping_all
)

## constructor ----

#' @rdname StoppingAll-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param report_label (`string`) \cr see slot definition.
#' @export
#' @example examples/Rules-class-StoppingAll.R
#'
StoppingAll <- function(stop_list, report_label = NA_character_) {
  .StoppingAll(
    stop_list = stop_list,
    report_label = report_label
  )
}
## default constructor ----

#' @rdname StoppingAll-class
#' @note Typically, end users will not use the `.DefaultStoppingAll()` function.
#' @export
.DefaultStoppingAll <- function() {
  StoppingAll(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    )
  )
}

# StoppingAny ----

## class ----

#' `StoppingAny`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingAny`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' At least one single stopping rule must be satisfied in order the result of
#' this rule to be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot report_label label for reporting
#'
#' @aliases StoppingAny
#' @export
#'
.StoppingAny <- setClass(
  Class = "StoppingAny",
  slots = c(
    stop_list = "list"
  ),
  prototype = prototype(
    stop_list = list(StoppingMinPatients(50), StoppingMinCohorts(5))
  ),
  contains = "Stopping",
  validity = v_stopping_all
)

## constructor ----

#' @rdname StoppingAny-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param report_label (`string`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingAny.R
#'
StoppingAny <- function(stop_list, report_label = NA_character_) {
  .StoppingAny(
    stop_list = stop_list,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingAny-class
#' @note Typically, end users will not use the `.DefaultStoppingAny()` function.
#' @export
.DefaultStoppingAny <- function() {
  StoppingAny(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    )
  )
}

# StoppingOrdinal ----

## class ----

#' `StoppingOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingOrdinal`] is the class for stopping based on a Stopping rule applied
#' to a specific toxicity grade in an ordinal CRM trial
#'
#' @slot grade (`integer`)\cr the grade to which the rule should be applied
#' @slot rule (`Stopping`)\cr the rule to apply
#'
#' @aliases StoppingOrdinal
#' @export
#'
.StoppingOrdinal <- setClass(
  Class = "StoppingOrdinal",
  slots = c(grade = "integer", rule = "Stopping"),
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingOrdinal-class
#' @param grade (`integer`)\cr see slot definition.
#' @param rule (`Stopping`)\cr see slot definition.
#' @example examples/Rules-class-StoppingOrdinal.R
#' @export
#'
StoppingOrdinal <- function(grade, rule) {
  .StoppingOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname StoppingOrdinal-class
#' @note Typically, end users will not use the `.DefaultStoppingOrdinal()` function.
#' @export
#'
.DefaultStoppingOrdinal <- function() {
  StoppingOrdinal(
    1L,
    StoppingTargetProb(target = c(0.2, 0.35), prob = 0.6)
  )
}

# StoppingExternal ----

## class ----

#' `StoppingExternal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingExternal`] is the class for stopping based on an external flag.
#'
#' @aliases StoppingExternal
#' @export
#'
.StoppingExternal <- setClass(
  Class = "StoppingExternal",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingExternal-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#' @example examples/Rules-class-StoppingExternal.R
#' @export
#'
StoppingExternal <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("Stopped because of external flag")
  )
  .StoppingExternal(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingExternal-class
#' @note Typically, end users will not use the `.DefaultStoppingExternal()` function.
#' @export
#'
.DefaultStoppingExternal <- StoppingExternal

# CohortSize ----

## class ----

#' `CohortSize`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSize`] is a class for cohort sizes.
#'
#' @seealso [`CohortSizeRange`], [`CohortSizeDLT`], [`CohortSizeConst`],
#'   [`CohortSizeParts`], [`CohortSizeMin`], [`CohortSizeMin`].
#'
#' @aliases CohortSize
#' @export
#'
setClass(
  Class = "CohortSize",
  contains = "CrmPackClass"
)

## default constructor

#' @rdname CohortSize-class
#' @note Typically, end users will not use the `DefaultCohortSize()` function.
#' @export
.DefaultCohortSize <- function() {
  stop(paste0(
    "Class CohortSize should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# CohortSizeRange ----

## class ----

#' `CohortSizeRange`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeRange`] is the class for cohort size based on dose range.
#'
#' @slot intervals (`numeric`)\cr a vector with the left bounds of the relevant
#'   dose intervals.
#' @slot cohort_size (`integer`)\cr an integer vector with the cohort sizes
#'   corresponding to the elements of `intervals`.
#'
#' @aliases CohortSizeRange
#' @export
#'
.CohortSizeRange <- setClass(
  Class = "CohortSizeRange",
  slots = c(
    intervals = "numeric",
    cohort_size = "integer"
  ),
  prototype = prototype(
    intervals = c(0, 20),
    cohort_size = c(1L, 3L)
  ),
  contains = "CohortSize",
  validity = v_cohort_size_range
)

## constructor ----

#' @rdname CohortSizeRange-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param cohort_size (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeRange.R
#'
CohortSizeRange <- function(intervals, cohort_size) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_size, lower = 0, any.missing = FALSE)

  .CohortSizeRange(
    intervals = intervals,
    cohort_size = as.integer(cohort_size)
  )
}

## default constructor ----

#' @rdname CohortSizeRange-class
#' @note Typically, end users will not use the `.DefaultCohortSizeRange()` function.
#' @export
.DefaultCohortSizeRange <- function() {
  CohortSizeRange(intervals = c(0L, 30L), cohort_size = c(1L, 3L))
}

# CohortSizeDLT ----

## class ----

#' `CohortSizeDLT`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeDLT`] is the class for cohort size based on number of DLTs.

#' @slot intervals (`integer`)\cr a vector with the left bounds of the
#'   relevant DLT intervals.
#' @slot cohort_size (`integer`)\cr a vector with the cohort sizes corresponding
#'   to the elements of `intervals`.
#'
#' @aliases CohortSizeDLT
#' @export
#'
.CohortSizeDLT <- setClass(
  Class = "CohortSizeDLT",
  slots = c(
    intervals = "integer",
    cohort_size = "integer"
  ),
  prototype = prototype(
    intervals = c(0L, 1L),
    cohort_size = c(1L, 3L)
  ),
  contains = "CohortSize",
  validity = v_cohort_size_dlt
)

## constructor ----

#' @rdname CohortSizeDLT-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param cohort_size (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeDLT.R
#'
CohortSizeDLT <- function(intervals, cohort_size) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_size, lower = 0, any.missing = FALSE)

  .CohortSizeDLT(
    intervals = as.integer(intervals),
    cohort_size = as.integer(cohort_size)
  )
}

## default constructor ----

#' @rdname CohortSizeDLT-class
#' @note Typically, end users will not use the `.DefaultCohortSizeDLT()` function.
#' @export
.DefaultCohortSizeDLT <- function() {
  CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
}


# CohortSizeConst ----

## class ----

#' `CohortSizeConst`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeConst`] is the class for fixed and constant size of cohort.
#'
#' @slot size (`integer`)\cr cohort size.
#'
#' @aliases CohortSizeConst
#' @export
#'
.CohortSizeConst <- setClass(
  Class = "CohortSizeConst",
  slots = c(size = "integer"),
  prototype = prototype(size = 3L),
  contains = "CohortSize",
  validity = v_cohort_size_const
)

## constructor ----

#' @rdname CohortSizeConst-class
#'
#' @param size (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeConst.R
#'
CohortSizeConst <- function(size) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(size, lower = 0)
  .CohortSizeConst(size = as.integer(size))
}

## default constructor ----

#' @rdname CohortSizeConst-class
#' @note Typically, end users will not use the `.DefaultCohortSizeConst()` function.
#' @export
.DefaultCohortSizeConst <- function() {
  CohortSizeConst(size = 3L)
}

# CohortSizeParts ----

## class ----

#' `CohortSizeParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeParts`] is the class for cohort size that changes for the second
#' part of the dose escalation. It works only in conjunction with [`DataParts`]
#' objects.
#'
#' @slot cohort_sizes (`integer`)\cr a vector of length two with two sizes, one for
#'   part 1, and one for part 2 respectively.
#'
#' @aliases CohortSizeParts
#' @export
#'
.CohortSizeParts <- setClass(
  Class = "CohortSizeParts",
  slots = c(cohort_sizes = "integer"),
  prototype = prototype(cohort_sizes = c(1L, 3L)),
  contains = "CohortSize",
  validity = v_cohort_size_parts
)

## constructor ----

#' @rdname CohortSizeParts-class
#'
#' @param cohort_sizes (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeParts.R
#'
CohortSizeParts <- function(cohort_sizes) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_sizes, lower = 0, any.missing = FALSE)
  .CohortSizeParts(cohort_sizes = as.integer(cohort_sizes))
}

## default constructor ----

#' @rdname CohortSizeParts-class
#' @note Typically, end users will not use the `.DefaultCohortSizeParts()` function.
#' @export
.DefaultCohortSizeParts <- function() {
  CohortSizeParts(cohort_sizes = c(1L, 3L))
}

# CohortSizeMax ----

## class ----

#' `CohortSizeMax`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeMax`] is the class for cohort size that is based on maximum of
#' multiple cohort size rules. The `cohort_sizes` slot stores a set of cohort
#' size rules, which are again the objects of class [`CohortSize`]. The maximum
#' of these individual cohort sizes is taken to give the final cohort size.
#'
#' @slot cohort_sizes (`list`)\cr a list of cohort size rules, i.e. objects
#' of class [`CohortSize`].
#'
#' @aliases CohortSizeMax
#' @export
#'
.CohortSizeMax <- setClass(
  Class = "CohortSizeMax",
  slots = c(cohort_sizes = "list"),
  prototype = prototype(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 30), cohort_size = c(1, 3)),
      CohortSizeDLT(intervals = c(0, 1), cohort_size = c(1, 3))
    )
  ),
  contains = "CohortSize",
  validity = v_cohort_size_max
)

## default constructor ----

#' @rdname CohortSizeMax-class
#' @note Typically, end users will not use the `.DefaultCohortSizeMax()` function.
#'
#' @export
.DefaultCohortSizeMax <- function() {
  CohortSizeMax(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 10), cohort_size = c(1L, 3L)),
      CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
    )
  )
}

## constructor ----

#' @rdname CohortSizeMax-class
#'
#' @param cohort_sizes (`list`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeMax.R
#'
CohortSizeMax <- function(cohort_sizes) {
  .CohortSizeMax(cohort_sizes = cohort_sizes)
}

# CohortSizeMin ----

## class ----

#' `CohortSizeMin`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeMin`] is the class for cohort size that is based on minimum of
#' multiple cohort size rules. The `cohort_sizes` slot stores a set of cohort
#' size rules, which are again the objects of class [`CohortSize`]. The minimum
#' of these individual cohort sizes is taken to give the final cohort size.
#'
#' @slot cohort_sizes (`list`)\cr a list of cohort size rules, i.e. objects
#' of class [`CohortSize`].
#'
#' @aliases CohortSizeMin
#' @export
#'
.CohortSizeMin <- setClass(
  Class = "CohortSizeMin",
  slots = c(cohort_sizes = "list"),
  prototype = prototype(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 30), cohort_size = c(1, 3)),
      CohortSizeDLT(intervals = c(0, 1), cohort_size = c(1, 3))
    )
  ),
  contains = "CohortSize",
  validity = v_cohort_size_max
)

## constructor ----

#' @rdname CohortSizeMin-class
#'
#' @param cohort_sizes (`list`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeMin.R
#'
CohortSizeMin <- function(cohort_sizes) {
  .CohortSizeMin(cohort_sizes = cohort_sizes)
}

## default constructor ----

#' @rdname CohortSizeMin-class
#' @note Typically, end users will not use the `.DefaultCohortSizeMin()` function.
#' @export
.DefaultCohortSizeMin <- function() {
  CohortSizeMin(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 10), cohort_size = c(1L, 3L)),
      CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
    )
  )
}

# CohortSizeOrdinal ----

## class ----

#' `CohortSizeOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`CohortSizeOrdinal`] is the class for cohort size for an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the grade at which the rule should be applied
#' @slot rule (`CohortSize`)\cr the `CohortSize` rule to apply.
#'
#' @aliases CohortSizeOrdinal
#' @export
#'
.CohortSizeOrdinal <- setClass(
  Class = "CohortSizeOrdinal",
  slots = c(
    grade = "integer",
    rule = "CohortSize"
  ),
  prototype = prototype(
    grade = 1L,
    rule = CohortSizeRange(intervals = c(0, 30), cohort_size = c(1L, 3L))
  ),
  contains = "CohortSize",
  validity = v_cohort_size_ordinal
)

## constructor ----

#' @rdname CohortSizeOrdinal-class
#'
#' @param grade (`integer`)\cr see slot definition.
#' @param rule (`CohortSize`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeOrdinal.R
#'
CohortSizeOrdinal <- function(grade, rule) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integer(grade, lower = 1, len = 1)
  assert_class(rule, "CohortSize")

  .CohortSizeOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname CohortSizeOrdinal-class
#' @note Typically, end users will not use the `.DefaultCohortSizeOrdinal()` function.
#' @export
.DefaultCohortSizeOrdinal <- function() {
  CohortSizeOrdinal(
    grade = 1L,
    rule = CohortSizeRange(intervals = c(0L, 30L), cohort_size = c(1L, 3L))
  )
}


# SafetyWindow ----

## class ----

#' `SafetyWindow`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindow`] is a class for safety window.
#'
#' @seealso [`SafetyWindowSize`], [`SafetyWindowConst`].
#'
#' @aliases SafetyWindow
#' @export
#'
setClass(
  Class = "SafetyWindow",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname SafetyWindow-class
#' @note Typically, end users will not use the `.DefaultSafetyWindow()` function.
#' @export
.DefaultSafetyWindow <- function() {
  stop(paste0(
    "Class SafetyWindow cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}


# SafetyWindowSize ----

## class ----

#' `SafetyWindowSize`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindowSize`] is the class for safety window length based on cohort
#' size. This class is used to decide the rolling rule from the clinical
#' perspective.
#'
#' @slot gap (`list`)\cr observed period of the previous patient before
#'   the next patient can be dosed. This is used as follows. If for instance,
#'   the cohort size is 4 and we want to specify three time intervals between
#'   these four consecutive patients, i.e. 7 units of time between the 1st and
#'   the 2nd patient, 5 units between the 2nd and the 3rd one, and finally 3
#'   units between the 3rd and the 4th one, then,
#'   `gap` = `list(c(7L, 5L, 3L))`. Sometimes, we want that the interval
#'   only between the 1st and 2nd patient should be increased for the
#'   safety consideration and the rest time intervals should remain constant,
#'   regardless of what the cohort size is. Then, `gap` = `list(c(7L, 3L))`
#'   and the the package will automatically repeat the last element of the vector
#'   for the remaining time intervals.
#' @slot size (`integer`)\cr a vector with the left bounds of the
#'   relevant cohort size intervals. This is used as follows. For instance, when
#'   we want to change the `gap` based on the cohort size, i.e. the time
#'   interval between the 1st and 2nd patient = 9 units of time and the rest
#'   time intervals are of 5 units of time when the cohort size is equal to or
#'   larger than 4. And the time interval between the 1st and 2nd patient = 7 units
#'   of time and the rest time intervals are 3 units of time when the cohort size
#'   is smaller than 4, then we specify both `gap = list(c(7, 3), c(9, 5))` and
#'   `size = c(0L, 4L)`. This means, the right bounds of the intervals are
#'   excluded from the interval, and the last interval goes from the last value
#'   to infinity.
#' @slot follow (`count`)\cr the period of time that each patient in the
#'   cohort needs to be followed before the next cohort opens.
#' @slot follow_min (`count`)\cr at least one patient in the cohort needs
#'   to be followed at the minimal follow up time.
#'
#' @aliases SafetyWindowSize
#' @export
#'
.SafetyWindowSize <- setClass(
  Class = "SafetyWindowSize",
  slots = c(
    gap = "list",
    size = "integer",
    follow = "integer",
    follow_min = "integer"
  ),
  prototype = prototype(
    gap = list(1:2, 1:2),
    size = c(1L, 3L),
    follow = 1L,
    follow_min = 1L
  ),
  contains = "SafetyWindow",
  validity = v_safety_window_size
)

## constructor ----

#' @rdname SafetyWindowSize-class
#'
#' @param gap see slot definition.
#' @param size see slot definition.
#' @param follow see slot definition.
#' @param follow_min see slot definition.
#'
#' @export
#' @example examples/Rules-class-SafetyWindowSize.R
#'
SafetyWindowSize <- function(gap, size, follow, follow_min) {
  assert_integerish(follow, lower = 0)
  assert_integerish(follow_min, lower = 0)
  for (g in gap) {
    assert_integerish(g, lower = 0)
  }
  assert_integerish(size, lower = 0)
  if (follow > follow_min) {
    warning(
      "The value of follow_min is typically larger than the value of follow"
    )
  }
  gap <- lapply(gap, as.integer)
  .SafetyWindowSize(
    gap = gap,
    size = as.integer(size),
    follow = as.integer(follow),
    follow_min = as.integer(follow_min)
  )
}

## default constructor ----

#' @rdname SafetyWindowSize-class
#' @note Typically, end users will not use the `.DefaultSafetyWindowSize()` function.
#' @export
.DefaultSafetyWindowSize <- function() {
  SafetyWindowSize(
    gap = list(c(7, 3), c(9, 5)),
    size = c(1, 4),
    follow = 7,
    follow_min = 14
  )
}

# SafetyWindowConst ----

## class ----

#' `SafetyWindowConst`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindowConst`] is the class for safety window length and it is used
#' when the `gap` should be kept constant across cohorts (though it may vary
#' within a cohort).
#'
#' @slot gap (`integer`)\cr a vector, the constant gap between patients.
#' @slot follow (`count`)\cr how long to follow each patient. The period of time
#'   that each patient in the cohort needs to be followed before the next cohort
#'   opens.
#' @slot follow_min (`count`)\cr minimum follow up. At least one patient in the
#'   cohort needs to be followed at the minimal follow up time.
#'
#' @aliases SafetyWindowConst
#' @export
#'
.SafetyWindowConst <- setClass(
  Class = "SafetyWindowConst",
  slots = c(
    gap = "integer",
    follow = "integer",
    follow_min = "integer"
  ),
  prototype = prototype(
    gap = 0L,
    follow = 1L,
    follow_min = 1L
  ),
  contains = "SafetyWindow",
  validity = v_safety_window_const
)

## constructor ----

#' @rdname SafetyWindowConst-class
#'
#' @param gap see slot definition.
#' @param follow see slot definition.
#' @param follow_min see slot definition.
#'
#' @export
#' @example examples/Rules-class-SafetyWindowConst.R
#'
SafetyWindowConst <- function(gap, follow, follow_min) {
  assert_integerish(follow, lower = 0)
  assert_integerish(follow_min, lower = 0)
  assert_integerish(gap, lower = 0)

  if (follow > follow_min) {
    warning(
      "The value of follow_min is typically larger than the value of follow"
    )
  }
  .SafetyWindowConst(
    gap = as.integer(gap),
    follow = as.integer(follow),
    follow_min = as.integer(follow_min)
  )
}

## default constructor ----

#' @rdname SafetyWindowConst-class
#' @note Typically, end users will not use the `.DefaultSafetyWindowConst()` function.
#' @export
.DefaultSafetyWindowConst <- function() {
  SafetyWindowConst(
    gap = 7,
    follow = 7,
    follow_min = 14
  )
}

# NextBest ----

#' Internal Helper Functions for Validation of [`NextBest`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`NextBest`] or inherited classes and therefore not exported.
#'
#' @name v_next_best
#' @param object (`NextBest`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_next_best validates that the [`NextBestMTD`] object
#'   contains valid `target` probability and `derive` function.
v_next_best_mtd <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestNCRM`] object
#'   contains valid `target` probability, `overdose` and `max_overdose_prob`
#'   probability ranges.
v_next_best_ncrm <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target),
    "target has to be a probability range"
  )
  v$check(
    test_probability_range(object@overdose),
    "overdose has to be a probability range"
  )
  v$check(
    test_probability(object@max_overdose_prob, bounds_closed = FALSE),
    "max_overdose_prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestNCRMLoss`] object
#'   contains valid objects.
v_next_best_ncrm_loss <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target, bounds_closed = FALSE),
    "target has to be a probability range excluding 0 and 1"
  )

  is_overdose_ok <- test_probability_range(
    object@overdose,
    bounds_closed = TRUE
  )
  v$check(is_overdose_ok, "overdose has to be a probability range")

  is_unacceptable_ok <- test_probability_range(
    object@unacceptable,
    bounds_closed = TRUE
  )
  v$check(is_unacceptable_ok, "unacceptable has to be a probability range")

  if (is_overdose_ok && is_unacceptable_ok) {
    v$check(
      object@overdose[2] <= object@unacceptable[1],
      "lower bound of unacceptable has to be >= than upper bound of overdose"
    )
  }
  if (is_unacceptable_ok) {
    losses_len <- ifelse(all(object@unacceptable == c(1, 1)), 3L, 4L)
    v$check(
      test_numeric(
        object@losses,
        lower = 0,
        finite = TRUE,
        any.missing = FALSE,
        len = losses_len
      ),
      "losses must be a vector of non-negative numbers of length 3 if unacceptable is c(1, 1), otherwise 4"
    )
  }
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestDualEndpoint`] object
#'   contains valid probability objects.
v_next_best_dual_endpoint <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@target_relative),
    "target_relative must be a flag"
  )
  if (isTRUE(object@target_relative)) {
    v$check(
      test_probability_range(object@target),
      "target has to be a probability range when target_relative is TRUE"
    )
  } else {
    v$check(
      test_range(object@target),
      "target must be a numeric range"
    )
  }
  v$check(
    test_probability_range(object@overdose),
    "overdose has to be a probability range"
  )
  v$check(
    test_probability(object@max_overdose_prob, bounds_closed = FALSE),
    "max_overdose_prob must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@target_thresh),
    "target_thresh must be a probability value from [0, 1] interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestMinDist`] object
#'   contains valid `target` object.
v_next_best_min_dist <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestEWOC`] object
#'   contains valid `target`, `overdose` and `max_overdose_prob` parameters.
v_next_best_ewoc <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_number(object@target, upper = object@overdose[1]),
    "target must be below the overdose interval"
  )
  v$check(
    test_probability_range(object@overdose, bounds_closed = TRUE),
    "overdose has to be a probability range"
  )
  v$check(
    test_probability(object@max_overdose_prob, bounds_closed = FALSE),
    "max_overdose_prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestInfTheory`] object
#'   contains valid `target` and `asymmetry` objects.
v_next_best_inf_theory <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_number(object@asymmetry, finite = TRUE) &&
      h_in_range(object@asymmetry, c(0, 2), FALSE),
    "asymmetry must be a number from (0, 2) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestTD`] object
#'   contains valid `prob_target_drt` and `prob_target_eot` probabilities.
v_next_best_td <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@prob_target_drt, bounds_closed = FALSE),
    "prob_target_drt must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob_target_eot, bounds_closed = FALSE),
    "prob_target_eot must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestTDsamples`] object
#'   contains valid `derive` function.
v_next_best_td_samples <- function(object) {
  v <- Validate()
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestMaxGainSamples`] object
#'   contains valid `derive` and `mg_derive` functions.
v_next_best_max_gain_samples <- function(object) {
  v <- Validate()
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$check(
    test_function(object@mg_derive, nargs = 1),
    "mg_derive must have a single argument"
  )
  v$check(
    test_number(object@mg_derive(1:5)),
    "mg_derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestProbMTDLTE`] object
#'   contains valid `target` probability and `method` string value.
v_next_best_prob_mtd_lte <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestProbMTDMinDist`] object
#'   contains valid `target` probability and `method` string value.
v_next_best_prob_mtd_min_dist <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

# Increments ----

#' Internal Helper Functions for Validation of [`Increments`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Increments`] or inherited classes and therefore not exported.
#'
#' @name v_increments
#' @param object (`Increments`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_increments validates that the [`IncrementsRelative`] object
#'   contains valid `intervals` and `increments` parameters.
v_increments_relative <- function(object) {
  v <- Validate()
  v$check(
    test_numeric(
      object@intervals,
      lower = 0,
      finite = TRUE,
      any.missing = FALSE,
      unique = TRUE,
      sorted = TRUE
    ),
    "intervals has to be a numerical vector with unique, finite, non-negative and sorted non-missing values"
  )
  v$check(
    test_numeric(
      object@increments,
      finite = TRUE,
      any.missing = FALSE,
      len = length(object@intervals)
    ),
    "increments has to be a numerical vector of the same length as `intervals` with finite values"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsRelativeParts`] object
#'   contains valid `dlt_start` and `clean_start` parameters.
v_increments_relative_parts <- function(object) {
  v <- Validate()
  is_dlt_start_ok <- test_int(object@dlt_start)
  v$check(is_dlt_start_ok, "dlt_start must be an integer number")
  if (is_dlt_start_ok) {
    v$check(
      test_int(object@clean_start, lower = object@dlt_start),
      "clean_start must be an integer number and it must be >= dlt_start"
    )
  }
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsRelativeDLT`] object
#'   contains valid `intervals` and `increments` parameters.
v_increments_relative_dlt <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@intervals,
      lower = 0,
      any.missing = FALSE,
      unique = TRUE,
      sorted = TRUE
    ),
    "intervals has to be an integer vector with unique, finite, non-negative and sorted non-missing values"
  )
  v$check(
    test_numeric(
      object@increments,
      finite = TRUE,
      any.missing = FALSE,
      len = length(object@intervals)
    ),
    "increments has to be a numerical vector of the same length as `intervals` with finite values"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsDoseLevels`] object
#'   contains valid `levels` and `basis_level` option.
v_increments_dose_levels <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@levels, lower = .Machine$double.xmin),
    "levels must be scalar positive integer"
  )
  v$check(
    test_string(object@basis_level, pattern = "^last$|^max$"),
    "basis_level must be either 'last' or 'max'"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsHSRBeta`]
#'   object contains valid probability target, threshold and shape parameters.
v_increments_hsr_beta <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$check(
    test_number(object@a, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter a must be a positive scalar"
  )
  v$check(
    test_number(object@b, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter b must be a positive scalar"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsMin`]
#'   object contains a list with `Increments` objects.
v_increments_min <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@increments_list, test_class, "Increments")),
    "all elements in increments_list must be of Increments class"
  )
  v$result()
}

#' @describeIn v_increments validates the [`IncrementsMaxToxProb`]
v_increments_maxtoxprob <- function(object) {
  v <- Validate()
  v$check(
    test_probabilities(object@prob),
    "prob must be a vector of probabilities with minimum length 1 and no missing values"
  )
  v$result()
}

# Stopping ----

#' Internal Helper Functions for Validation of [`Stopping`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Stopping`] or inherited classes and therefore not exported.
#'
#' @name v_stopping
#' @param object (`Stopping`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_stopping validates that the [`StoppingCohortsNearDose`]
#'   object contains valid `nCohorts` and `percentage` parameters.
v_stopping_cohorts_near_dose <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nCohorts, lower = .Machine$double.xmin),
    "nCohorts must be positive integer scalar"
  )
  v$check(
    test_probability(object@percentage / 100),
    "percentage must be a number between 0 and 100"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingPatientsNearDose`]
#'   object contains valid `nPatients` and `percentage` parameters.
v_stopping_patients_near_dose <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nPatients, lower = .Machine$double.xmin),
    "nPatients must be positive integer scalar"
  )
  v$check(
    test_probability(object@percentage / 100),
    "percentage must be a number between 0 and 100"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMinCohorts`]
#'   object contains valid `nCohorts` parameter.
v_stopping_min_cohorts <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nCohorts, lower = .Machine$double.xmin),
    "nCohorts must be positive integer scalar"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMinPatients`]
#'   object contains valid `nPatients` parameter.
v_stopping_min_patients <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nPatients, lower = .Machine$double.xmin),
    "nPatients must be positive integer scalar"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTargetProb`]
#'   object contains valid `target` and `prob` parameters.
v_stopping_target_prob <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target),
    "target has to be a probability range"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMTDdistribution`]
#'   object contains valid `target`, `thresh` and `prob` parameters.
v_stopping_mtd_distribution <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@thresh, bounds_closed = FALSE),
    "thresh must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMTDCV`] object
#'   contains valid probability target and percentage threshold.
v_stopping_mtd_cv <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@thresh_cv / 100, bounds_closed = c(FALSE, TRUE)),
    "thresh_cv must be percentage > 0"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTargetBiomarker`] object
#'   contains valid `target`, `is_relative` and `prob`slots.
v_stopping_target_biomarker <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@is_relative),
    "is_relative must be a flag"
  )
  if (isTRUE(object@is_relative)) {
    v$check(
      test_probability_range(object@target),
      "target has to be a probability range when is_relative flag is 'TRUE'"
    )
  } else {
    v$check(
      test_range(object@target, finite = TRUE),
      "target must be a numeric range"
    )
  }
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingList`] object
#'   contains valid `stop_list`, `summary` slots.
v_stopping_list <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@stop_list, test_class, "Stopping")),
    "every stop_list element must be of class 'Stopping'"
  )
  is_summary_ok <- test_function(object@summary, nargs = 1)
  v$check(
    is_summary_ok,
    "summary must be a function that accepts a single argument, without ..."
  )
  if (is_summary_ok) {
    summary_res <- object@summary(
      rep(c(TRUE, FALSE), length.out = length(object@stop_list))
    )
    v$check(
      test_flag(summary_res),
      "summary must accept a logical vector of the same length as 'stop_list' and return a boolean value"
    )
  }
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingAll`] object
#'   contains valid `stop_list` slot.
v_stopping_all <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@stop_list, test_class, "Stopping")),
    "every stop_list element must be of class 'Stopping'"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTDCIRatio`] object
#'   contains valid `target_ratio` and  `prob_target` slots.
v_stopping_tdci_ratio <- function(object) {
  v <- Validate()
  v$check(
    test_number(
      object@target_ratio,
      lower = .Machine$double.xmin,
      finite = TRUE
    ),
    "target_ratio must be a positive number"
  )
  v$check(
    test_probability(object@prob_target),
    "prob_target must be a probability value from [0, 1] interval"
  )
  v$result()
}

# CohortSize ----

#' Internal Helper Functions for Validation of [`CohortSize`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`CohortSize`] or inherited classes and therefore not exported.
#'
#' @name v_cohort_size
#' @param object (`CohortSize`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_cohort_size validates that the [`CohortSizeRange`] object
#'   contains valid `intervals` and  `cohort_size` slots.
v_cohort_size_range <- function(object) {
  v <- Validate()
  v$check(
    test_numeric(
      object@intervals,
      lower = 0,
      finite = TRUE,
      any.missing = FALSE,
      min.len = 1,
      unique = TRUE,
      sorted = TRUE
    ),
    "intervals must be a numeric vector with non-negative, sorted (asc.) and unique values"
  )
  v$check(
    test_integer(
      object@cohort_size,
      lower = 0,
      any.missing = FALSE,
      len = length(object@intervals)
    ),
    "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeDLT`] object
#'   contains valid `intervals` and  `cohort_size` slots.
v_cohort_size_dlt <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@intervals,
      lower = 0,
      any.missing = FALSE,
      min.len = 1,
      unique = TRUE,
      sorted = TRUE
    ),
    "intervals must be an integer vector with non-negative, sorted (asc.) and unique values"
  )
  v$check(
    test_integer(
      object@cohort_size,
      lower = 0,
      any.missing = FALSE,
      len = length(object@intervals)
    ),
    "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeConst`] object
#'   contains valid `size` slot.
v_cohort_size_const <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@size, lower = 0),
    "size needs to be a non-negative scalar"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeParts`] object
#'   contains valid `sizes` slot.
v_cohort_size_parts <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@cohort_sizes,
      lower = .Machine$double.xmin,
      any.missing = FALSE,
      len = 2
    ),
    "cohort_sizes needs to be an integer vector of length 2 with all elements positive"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeMax`] object
#'   contains valid `cohort_sizes` slot.
v_cohort_size_max <- function(object) {
  v <- Validate()
  v$check(
    test_list(
      object@cohort_sizes,
      types = "CohortSize",
      any.missing = FALSE,
      min.len = 2,
      unique = TRUE
    ),
    "cohort_sizes must be a list of CohortSize (unique) objects only and be of length >= 2"
  )
  v$result()
}

# SafetyWindow ----

#' Internal Helper Functions for Validation of [`SafetyWindow`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`SafetyWindow`] or inherited classes and therefore not exported.
#'
#' @name v_safety_window
#' @param object (`SafetyWindow`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_safety_window validates that the [`SafetyWindowSize`] object
#'   contains valid slots.
v_safety_window_size <- function(object) {
  v <- Validate()
  v$check(
    test_list(object@gap, types = "integer", any.missing = FALSE, min.len = 1),
    "gap must be a list of length >= 1 with integer vectors only"
  )
  v$check(
    all(sapply(
      object@gap,
      test_integer,
      lower = 0,
      any.missing = FALSE,
      min.len = 1
    )),
    "every element in gap list has to be an integer vector with non-negative and non-missing values"
  )
  pg_len <- length(object@gap)
  v$check(
    test_integer(
      object@size,
      lower = .Machine$double.xmin,
      any.missing = FALSE,
      len = pg_len,
      unique = TRUE,
      sorted = TRUE
    ),
    "size has to be an integer vector, of the same length as gap, with positive, unique and sorted non-missing values"
  )
  v$check(
    test_int(object@follow, lower = .Machine$double.xmin),
    "follow has to be a positive integer number"
  )
  v$check(
    test_int(object@follow_min, lower = .Machine$double.xmin),
    "follow_min has to be a positive integer number"
  )
  v$result()
}

#' @describeIn v_safety_window validates that the [`SafetyWindowConst`] object
#'   contains valid slots.
v_safety_window_const <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@gap, lower = 0, any.missing = FALSE),
    "gap has to be an integer vector with non-negative and non-missing elements"
  )
  v$check(
    test_int(object@follow, lower = .Machine$double.xmin),
    "follow has to be a positive integer number"
  )
  v$check(
    test_int(object@follow_min, lower = .Machine$double.xmin),
    "follow_min has to be a positive integer number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestOrdinal`] object
#'   contains valid `grade` and standard `NextBest` rule.
v_next_best_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "NextBest"),
    "rule must be a NextBest object"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsOrdinal`] object
#'   contains valid `grade` and standard `Increments` rule.
v_increments_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "Increments"),
    "rule must be a Increments object"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`CohortSizeOrdinal`] object
#'   contains valid `grade` and standard `CohortSize` rule.
v_cohort_size_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "CohortSize"),
    "rule must be a CohortSize object"
  )
  v$result()
}

#' @include helpers.R
#' @include Data-validity.R
#' @include CrmPackClass-class.R
NULL

# GeneralData-class ----

#' `GeneralData`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`GeneralData`] is a class for general data input.
#'
#' @slot ID (`integer`)\cr unique patient IDs.
#' @slot cohort (`integer`)\cr the cohort (non-negative sorted) indices.
#' @slot nObs (`integer`)\cr number of observations, a single value.
#'
#' @aliases GeneralData
#' @export
#'
.GeneralData <- setClass(
  Class = "GeneralData",
  slots = c(
    ID = "integer",
    cohort = "integer",
    nObs = "integer"
  ),
  prototype = prototype(
    ID = integer(),
    cohort = integer(),
    nObs = 0L
  ),
  contains = "CrmPackClass",
  validity = v_general_data
)

## default constructor ----

#' @rdname GeneralData-class
#' @note Typically, end users will not use the `.DefaultDataGeneral()` function.
#' @export
.DefaultDataGeneral <- function() {
  stop(paste0(
    "Class DataGeneral cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# Data ----

## class ----

#' `Data`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Data`] is a class for the data input.
#' It inherits from [`GeneralData`].
#'
#' @slot x (`numeric`)\cr the doses for the patients.
#' @slot y (`integer`)\cr the vector of toxicity events (0 or 1 integers).
#' @slot doseGrid (`numeric`)\cr the vector of all possible doses (sorted),
#'   i.e. the dose grid.
#' @slot nGrid (`integer`)\cr number of gridpoints.
#' @slot xLevel (`integer`)\cr the levels for the doses the patients have been given,
#'   w.r.t `doseGrid`.
#' @slot placebo (`logical`)\cr if `TRUE` the first dose level
#'   in the `doseGrid`is considered as PLACEBO.
#'
#' @aliases Data
#' @export
#'
.Data <- setClass(
  Class = "Data",
  contains = "GeneralData",
  slots = c(
    x = "numeric",
    y = "integer",
    doseGrid = "numeric",
    nGrid = "integer",
    xLevel = "integer",
    placebo = "logical"
  ),
  prototype = prototype(
    x = numeric(),
    y = integer(),
    doseGrid = numeric(),
    nGrid = 0L,
    xLevel = integer(),
    placebo = FALSE
  ),
  validity = v_data
)

## constructor ----

#' @rdname Data-class
#'
#' @details The `cohort` can be missing if and only if `placebo` is equal to
#'   `FALSE`.
#'
#' @note `ID` and `cohort` can be missing. Then a message will be issued
#'   and the variables will be filled with default IDs and best guesses cohort,
#'   i.e. a sorted (in ascending order) sequence of values from `{1, 2, ...}`.
#'
#' @param x (`numeric`)\cr the doses for the patients.
#' @param y (`integer`)\cr the vector of toxicity events (0 or 1).
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param ID (`integer`)\cr unique patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param cohort (`integer`)\cr the cohort (non-negative sorted) indices.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param doseGrid (`numeric`)\cr all possible doses.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level
#'   in the `doseGrid` is considered as placebo.
#' @param ... not used.
#'
#' @export
#' @example examples/Data-class.R
#'
Data <- function(
  x = numeric(),
  y = integer(),
  ID = integer(),
  cohort = integer(),
  doseGrid = numeric(),
  placebo = FALSE,
  ...
) {
  assert_numeric(x)
  assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
  assert_integerish(ID, unique = TRUE, any.missing = FALSE)
  assert_integerish(cohort)
  if (length(x) > 0) {
    assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE, min.len = 1)
  } else {
    assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
  }
  assert_flag(placebo)

  doseGrid <- sort(doseGrid)
  assert_subset(x, doseGrid)

  if (length(ID) == 0 && length(x) > 0) {
    message("Used default patient IDs!")
    ID <- seq_along(x)
  } else {
    assert_integerish(ID, unique = TRUE)
  }

  if (!placebo && length(cohort) == 0 && length(x) > 0) {
    message("Used best guess cohort indices!")
    # This is just assuming that consecutive patients
    # in the data set are in the same cohort if they
    # have the same dose. Note that this could be wrong,
    # if two subsequent cohorts are at the same dose.
    cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
  } else {
    assert_integerish(cohort)
  }

  .Data(
    x = as.numeric(x),
    y = as.integer(y),
    ID = as.integer(ID),
    cohort = as.integer(cohort),
    doseGrid = as.numeric(doseGrid),
    nObs = length(x),
    nGrid = length(doseGrid),
    xLevel = match_within_tolerance(x, doseGrid),
    placebo = placebo
  )
}

## default constructor ----

#' @rdname Data-class
#' @note Typically, end users will not use the `.DefaultData()` function.
#' @export
.DefaultData <- function() {
  Data(
    doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
    ID = 1L:3L,
    cohort = 1L:3L,
    x = c(1, 3, 5),
    y = rep(0L, 3)
  )
}

# DataDual ----

## class ----

#' `DataDual`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataDual`] is a class for the dual endpoint data.
#' It inherits from [`Data`] and it contains additional biomarker information.
#'
#' @slot w (`numeric`)\cr the continuous vector of biomarker values.
#'
#' @aliases DataDual
#' @export
#'
.DataDual <- setClass(
  Class = "DataDual",
  slots = c(w = "numeric"),
  prototype = prototype(w = numeric()),
  contains = "Data",
  validity = v_data_dual
)

## constructor ----

#' @rdname DataDual-class
#'
#' @param w (`numeric`)\cr the continuous vector of biomarker values.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataDual.R
#'
DataDual <- function(w = numeric(), ...) {
  d <- Data(...)
  .DataDual(d, w = w)
}


## default constructor ----

#' @rdname DataDual-class
#' @note Typically, end users will not use the `.DefaultDataDual()` function.
#' @export
.DefaultDataDual <- function() {
  set.seed(1230)
  DataDual(
    x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
    y = c(0, 0, 0, 0, 0, 0, 1, 0),
    w = rnorm(8),
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
  )
}

# DataParts ----

## class ----

#' `DataParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataParts`] is a class for the data with two study parts.
#' It inherits from [`Data`] and it contains additional information
#' on the two study parts.
#'
#' @slot part (`integer`)\cr which part does each of the patients belong to?
#' @slot nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
#' @slot part1Ladder (`numeric`)\cr what is the escalation ladder for
#'   part 1? This shall be an ordered subset of the `doseGrid`.
#'
#' @aliases DataParts
#' @export
#'
.DataParts <- setClass(
  Class = "DataParts",
  slots = c(
    part = "integer",
    nextPart = "integer",
    part1Ladder = "numeric"
  ),
  prototype = prototype(
    part = integer(),
    nextPart = 1L,
    part1Ladder = numeric()
  ),
  contains = "Data",
  validity = v_data_parts
)

## constructor ----

#' @rdname DataParts-class
#'
#' @param part (`integer`)\cr which part does each of the patients belong to?
#' @param nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
#' @param part1Ladder (`numeric`)\cr what is the escalation ladder for part 1?
#'   This shall be an ordered subset of the `doseGrid`.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataParts.R
#'
DataParts <- function(
  part = integer(),
  nextPart = 1L,
  part1Ladder = numeric(),
  ...
) {
  d <- Data(...)
  .DataParts(
    d,
    part = part,
    nextPart = nextPart,
    part1Ladder = part1Ladder
  )
}

## default constructor ----

#' @rdname DataParts-class
#' @note Typically, end users will not use the `.DefaultDataParts()` function.
#' @export
.DefaultDataParts <- function() {
  DataParts(
    x = c(0.1, 0.5, 1.5),
    y = c(0, 0, 0),
    ID = 1:3,
    cohort = 1:3,
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    part = c(1L, 1L, 1L),
    nextPart = 1L,
    part1Ladder = c(0.1, 0.5, 1.5, 3, 6, 10)
  )
}


# DataMixture ----

## class ----

#' `DataMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataMixture`] is a class for the data with mixture sharing.
#' It inherits from [`Data`] and it contains additional information
#' on the mixture sharing.
#'
#' @slot xshare (`numeric`)\cr the doses for the share patients.
#' @slot yshare (`integer`)\cr the vector of toxicity events (0 or 1)
#'   for the share patients.
#' @slot nObsshare (`count`)\cr number of share patients.
#'
#' @aliases DataMixture
#' @export
#'
.DataMixture <- setClass(
  Class = "DataMixture",
  slots = c(
    xshare = "numeric",
    yshare = "integer",
    nObsshare = "integer"
  ),
  prototype = prototype(
    xshare = numeric(),
    yshare = integer(),
    nObsshare = 0L
  ),
  contains = "Data",
  validity = v_data_mixture
)

## constructor ----

#' @rdname DataMixture-class
#'
#' @param xshare (`numeric`)\cr the doses for the share patients.
#' @param yshare (`integer`)\cr the vector of toxicity events (0 or 1)
#'   for the share patients. You can also supply `numeric` vectors,
#'   but these will then be converted to `integer` internally.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataMixture.R
#'
DataMixture <- function(xshare = numeric(), yshare = integer(), ...) {
  d <- Data(...)
  assert_integerish(yshare)
  assert_numeric(xshare)
  .DataMixture(
    d,
    xshare = as.numeric(xshare),
    yshare = as.integer(yshare),
    nObsshare = length(xshare)
  )
}

## default constructor ----

#' @rdname DataMixture-class
#' @note Typically, end users will not use the `.DefaultDataMixture()` function.
#' @export
.DefaultDataMixture <- function() {
  DataMixture(
    xshare = c(12, 14, 16, 18.0),
    yshare = c(0L, 1L, 1L, 1L),
    nObsshare = 4L,
    x = c(0.1, 0.5, 1.5),
    y = c(0, 0, 0),
    ID = 1L:3L,
    cohort = 1L:3L,
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2))
  )
}


# DataDA ----

## class ----

#' `DataDA`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataDA`] is a class for the time-to-DLT augmented data.
#' It inherits from [`Data`] and it contains additional DLT free survival times.
#'
#' @note `survival time` here refers to the time period for which the subject
#'   did not experience any DLT, and is not referring to deaths.
#'
#' @slot u (`numeric`)\cr the continuous vector of DLT free survival times.
#' @slot t0 (`numeric`)\cr time of initial dosing for each patient.
#'   Non-negative values sorted in ascending order.
#' @slot Tmax (`number`)\cr the DLT observation period.
#'
#' @aliases DataDA
#' @export
#'
.DataDA <- setClass(
  Class = "DataDA",
  slots = c(
    u = "numeric",
    t0 = "numeric",
    Tmax = "numeric"
  ),
  prototype = prototype(
    u = numeric(),
    t0 = numeric(),
    Tmax = 0 + .Machine$double.xmin
  ),
  contains = "Data",
  validity = v_data_da
)

## constructor ----

#' @rdname DataDA-class
#'
#' @param u (`numeric`)\cr the continuous vector of DLT free survival times.
#' @param t0 (`numeric`)\cr time of initial dosing for each patient.
#'   Non-negative values sorted in ascending order.
#'   Default to vector of 0s of length equal to length of `u`.
#' @param Tmax (`number`)\cr the DLT observation period.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataDA.R
#'
DataDA <- function(
  u = numeric(),
  t0 = numeric(length(u)),
  Tmax = 0 + .Machine$double.xmin,
  ...
) {
  d <- Data(...)
  .DataDA(
    d,
    u = as.numeric(u),
    t0 = as.numeric(t0),
    Tmax = as.numeric(Tmax)
  )
}

## default constructor ----

#' @rdname DataDA-class
#' @note Typically, end users will not use the `.DefaultDataDA()` function.
#' @export
.DefaultDataDA <- function() {
  DataDA(
    u = c(42, 30, 15, 5, 20, 25, 30, 60),
    t0 = c(0, 15, 30, 40, 55, 70, 75, 85),
    Tmax = 60,
    x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
    y = c(0, 0, 1, 1, 0, 0, 1, 0),
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
  )
}

# DataOrdinal ----

## class ----

#' `DataOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DataOrdinal`] is a class for ordinal toxicity data.
#' It inherits from [`GeneralData`] and it describes toxicity responses on an
#' ordinal rather than binary scale.
#'
#' @note This class has been implemented as a sibling of the existing `Data` class
#' (rather than as a parent or child) to minimise the risk of unintended side
#' effects on existing classes and methods.
#'
#' The default setting for the `yCategories` slot replicates the behaviour
#' of the existing `Data` class.
#'
#' @aliases DataOrdinal
#' @export
.DataOrdinal <- setClass(
  Class = "DataOrdinal",
  contains = "GeneralData",
  slots = c(
    x = "numeric",
    y = "integer",
    doseGrid = "numeric",
    nGrid = "integer",
    xLevel = "integer",
    yCategories = "integer",
    placebo = "logical"
  ),
  prototype = prototype(
    x = numeric(),
    y = integer(),
    doseGrid = numeric(),
    nGrid = 0L,
    xLevel = integer(),
    yCategories = c("No DLT" = 0L, "DLT" = 1L),
    placebo = FALSE
  ),
  validity = v_data_ordinal
)

## constructor ----

#' @rdname DataOrdinal-class
#' @param yCategories (named `integer`)\cr the names and codes for the
#' toxicity categories used in the data.  Category labels are taken from the
#' names of the vector.  The names of the vector must be unique and its values
#' must be sorted and take the values 0, 1, 2, ...
#' @inheritParams Data
#' @inherit Data details note params
#' @example examples/Data-class-DataOrdinal.R
#' @export
DataOrdinal <- function(
  x = numeric(),
  y = integer(),
  ID = integer(),
  cohort = integer(),
  doseGrid = numeric(),
  placebo = FALSE,
  yCategories = c("No DLT" = 0L, "DLT" = 1L),
  ...
) {
  assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
  assert_integerish(
    yCategories,
    any.missing = FALSE,
    unique = TRUE,
    names = "unique",
    min.len = 2
  )
  assert_flag(placebo)

  doseGrid <- as.numeric(sort(doseGrid))

  if (length(ID) == 0 && length(x) > 0) {
    message("Used default patient IDs!")
    ID <- seq_along(x)
  } else {
    assert_integerish(ID, unique = TRUE)
  }

  if (!placebo && length(cohort) == 0 && length(x) > 0) {
    message("Used best guess cohort indices!")
    # This is just assuming that consecutive patients
    # in the data set are in the same cohort if they
    # have the same dose. Note that this could be wrong,
    # if two subsequent cohorts are at the same dose.
    cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
  } else {
    assert_integerish(cohort)
  }

  .DataOrdinal(
    x = as.numeric(x),
    y = as.integer(y),
    ID = as.integer(ID),
    cohort = as.integer(cohort),
    doseGrid = doseGrid,
    nObs = length(x),
    nGrid = length(doseGrid),
    xLevel = match_within_tolerance(x = x, table = doseGrid),
    placebo = placebo,
    yCategories = yCategories
  )
}


## default constructor ----

#' @rdname DataOrdinal-class
#' @note Typically, end users will not use the `.DefaultDataOrdinal()` function.
#' @export
.DefaultDataOrdinal <- function() {
  DataOrdinal(
    x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
    y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
    ID = 1L:10L,
    cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
    doseGrid = c(seq(from = 10, to = 100, by = 10)),
    yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
    placebo = FALSE
  )
}

# DataGrouped ----

## class ----

#' `DataGrouped`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataGrouped`] is a class for a two groups dose escalation data set,
#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
#' arm. It inherits from [`Data`] and it contains the additional group information.
#'
#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
#'
#' @aliases DataGrouped
#' @export
.DataGrouped <- setClass(
  Class = "DataGrouped",
  slots = c(
    group = "factor"
  ),
  prototype = prototype(
    group = factor(levels = c("mono", "combo"))
  ),
  contains = "Data",
  validity = v_data_grouped
)

#' @rdname DataGrouped-class
#'
#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
#'   If `character` then will be coerced to `factor` with the correct levels
#'   internally.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataGrouped.R
#'
DataGrouped <- function(group = character(), ...) {
  d <- Data(...)
  if (!is.factor(group)) {
    assert_character(group)
    assert_subset(group, choices = c("mono", "combo"))
    group <- factor(group, levels = c("mono", "combo"))
  }
  .DataGrouped(
    d,
    group = group
  )
}

## default constructor ----

#' @rdname DataGrouped-class
#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
#' @export
.DefaultDataGrouped <- function() {
  DataGrouped(
    group = c("mono", "mono", "combo"),
    x = c(1, 3, 5),
    y = c(0, 0, 0),
    ID = 1L:3L,
    cohort = 1L:3L,
    doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
    placebo = FALSE
  )
}

#' @include helpers.R
NULL

#' Appending a Dummy Number for Selected Slots in Data
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A helper function that appends a dummy value to a given slots in [`GeneralData`]
#' class object, if and only if the total number of observations (as indicated
#' by `object@nObs`) equals to `1`. Otherwise, the `object` is not changed.
#'
#' @note The main motivation behind this function is related to the `JAGS`.
#'   If there is only one observation, the data is not passed correctly to
#'   `JAGS`, i.e. e.g. `x` and `y` are treated like scalars in the data file.
#'   Therefore it is necessary to add dummy values to the vectors in this case
#'   As we don't change the number of observations (`nObs`), this addition of
#'   zeros doesn't affect the results of `JAGS` computations.
#'
#' @param object (`GeneralData`)\cr object into which dummy values will be added.
#' @param where (`character`)\cr names of slots in `object` to which a `dummy`
#'   number will be appended.
#' @param dummy (`number`)\cr a dummy number that will be appended to selected
#'   slots in `object`. Default to `0`.
#'
#' @return A [`GeneralData`] object with slots updated with dummy number.
#'
#' @export
#' @example examples/helpers-jags_add_dummy.R
#'
h_jags_add_dummy <- function(object, where, dummy = 0) {
  assert_class(object, "GeneralData")
  assert_character(where)
  assert_subset(where, slotNames(object))
  assert_number(dummy)

  if (object@nObs == 1L) {
    for (i in where) {
      # Add dummy value and preserve the class.
      slot(object, i) <- as(c(slot(object, i), dummy), class(slot(object, i)))
    }
  }
  object
}

#' Joining `JAGS` Models
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This helper function joins two JAGS models in the way that the body of the
#' second model is appended to the body of the first model (in this order).
#' After that, the first, body-extended model is returned. The arguments of
#' `model1`, `model2` model functions (if any) are not combined in any way.
#'
#' @note `model1` and `model2` functions must have a multi-expression
#'   body, i.e. braced expression(s). Environments or any attributes of the
#'   function bodies are not preserved in any way after joining.
#'
#' @param model1 (`function`)\cr the first model to join.
#' @param model2 (`function`)\cr the second model to join.
#'
#' @return joined models.
#'
#' @export
#'
h_jags_join_models <- function(model1, model2) {
  assert_function(model1)
  assert_function(model2)
  assert_class(body(model1), "{")
  assert_class(body(model2), "{")

  # This workaround is needed to avoid bugs related to covr-injected code.
  if (h_covr_active()) {
    body(model2) <- h_covr_detrace(body(model2))
  }

  body2 <- as.list(body(model2))
  if (length(body2) >= 2) {
    body1 <- as.list(body(model1))
    body(model1) <- as.call(c(body1, body2[-1]))
  }
  model1
}


#' Setting Initial Values for `JAGS` Model Parameters
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that prepares an object for `inits` argument of
#'   [rjags::jags.model()], which is invoked by [mcmc()] method. The `inits`
#'   argument specifies initial values for model parameters.
#'
#' @param model (`GeneralModel`)\cr an input model.
#' @param data (`GeneralData`)\cr an input data.
#'
#' @return A `list` of starting values for parameters required to be initialized
#'   in the MCMC `JAGS `sampler.
#'
#' @export
#' @example examples/helpers-jags_get_model_inits.R
#'
h_jags_get_model_inits <- function(model, data) {
  assert_class(model, "GeneralModel")
  assert_class(data, "GeneralData")

  inits <- do.call(model@init, h_slots(data, formalArgs(model@init)))
  assert_list(inits)
  inits[sapply(inits, length) > 0L]
}

#' Getting Data for `JAGS`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that prepares an object for `data` argument of
#'   [rjags::jags.model()], which is invoked by [mcmc()] method.
#'
#' @param model (`GeneralModel`)\cr an input model.
#' @param data (`GeneralData`)\cr an input data.
#' @param from_prior (`flag`)\cr sample from the prior only? In this case
#'   data will not be appended to the output, i.e. only the variables required
#'   by the `model@priormodel` model will be returned in data.
#'
#' @export
#' @example examples/helpers-jags_get_data.R
#'
h_jags_get_data <- function(model, data, from_prior) {
  assert_class(model, "GeneralModel")
  assert_class(data, "GeneralData")
  assert_flag(from_prior)

  # 1) Extract variables from `data` as required by `modelspecs`.
  ms_args_names <- formalArgs(model@modelspecs)
  ms_args <- if ("from_prior" %in% ms_args_names) {
    c(
      h_slots(data, setdiff(ms_args_names, "from_prior")),
      list(from_prior = from_prior)
    )
  } else {
    h_slots(data, ms_args_names)
  }
  modelspecs <- do.call(model@modelspecs, ms_args)
  assert_list(modelspecs)

  # 2) Extract variables from `data` as required by `datanames`.
  datanames <- if (from_prior) {
    model@datanames_prior
  } else {
    union(model@datanames, model@datanames_prior)
  }

  # Add dummy to ensure that e.g. `x` and `y` in `data` won't be treated as
  # scalars by `JAGS` if `data@nObs == 1`, which leads to failures.
  add_where <- setdiff(
    datanames,
    c("nObs", "nGrid", "nObsshare", "yshare", "xshare", "Tmax")
  )
  data <- h_jags_add_dummy(data, where = add_where)

  data_model <- h_slots(data, datanames)
  c(data_model, modelspecs)
}

#' Writing JAGS Model to a File
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function converts a R function with JAGS model into a text and then
#' writes it into a given file. During the "model into text" conversion, the
#' format of numbers of which absolute value is less than `0.001` or greater
#' than `10000` is changed. These numbers will be converted into scientific
#' format with specified number of significant digits using [formatC()]
#' function.
#'
#' @note JAGS syntax allows truncation specification like `dnorm(...) I(...)`,
#'   which is illegal in R. To overcome this incompatibility, use dummy operator
#'   `\%_\%` before `I(...)`, i.e. `dnorm(...) \%_\% I(...)` in the model's
#'   code. This dummy operator `\%_\%` will be removed just before saving the
#'   JAGS code into a file.
#'   Due to technical issues related to conversion of numbers to scientific
#'   format, it is required that the body of a model function does not contain
#'   `TEMP_NUM_PREF_` or `_TEMP_NUM_SUF` character constants in its body.
#'
#' @param model (`function`)\cr function containing the JAGS model.
#' @param file (`string` or `NULL`)\cr the name of the file (including the
#'   optional path) where the model will be saved. If `NULL`, the file will be
#'   created in a `R_crmPack` folder placed under temporary directory indicated
#'   by [tempdir()] function.
#' @param digits (`count`)\cr a desired number of significant digits for
#'   for numbers used in JAGS input, see [formatC()].
#' @return The name of the file where the model was saved.
#'
#' @export
#' @example examples/helpers-jags_write_model.R
#'
h_jags_write_model <- function(model, file = NULL, digits = 5) {
  assert_function(model)
  assert_count(digits)

  # This workaround is needed to avoid bugs related to covr-injected code.
  if (h_covr_active()) {
    body(model) <- h_covr_detrace(body(model))
  }

  if (!is.null(file)) {
    assert_path_for_output(file)
  } else {
    dir <- file.path(tempdir(), "R_crmPack")
    # Don't warn, as the temp dir often exists (which is OK).
    dir.create(dir, showWarnings = FALSE)
    file <- tempfile(
      pattern = "jags_model_fun",
      tmpdir = dir,
      fileext = ".txt"
    )
  }

  # Replace scientific notation.
  model_sci_replaced <- h_rapply(
    x = body(model),
    fun = h_format_number,
    classes = c("integer", "numeric"),
    digits = digits,
    prefix = "TEMP_NUM_PREF_",
    suffix = "_TEMP_NUM_SUF"
  )
  # Transform `model` body into character vector.
  model_text <- deparse(model_sci_replaced, control = NULL)
  model_text <- gsub("\"TEMP_NUM_PREF_|_TEMP_NUM_SUF\"", "", model_text)
  model_text <- gsub("%_% ", "", model_text)
  model_text <- c("model", model_text)

  log_trace("Writting JAGS model function into: %s", file)
  writeLines(model_text, con = file)
  file
}

#' Extracting Samples from `JAGS` `mcarray` Object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that extracts a sample from
#'   [`rjags::mcarray.object`] S3 class object. The [`rjags::mcarray.object`]
#'   object is used by the [rjags::jags.samples()] function to represent MCMC
#'   output from a `JAGS` model.
#'
#' @param x an [`rjags::mcarray.object`] object.
#'
#' @export
#'
h_jags_extract_samples <- function(x) {
  assert_class(x, "mcarray")

  x <- x[,, 1L]
  # In case that there are multiple parameters in a node.
  if (is.matrix(x)) {
    x <- t(x)
  }
  x
}

# StoppingOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingOrdinal
knit_print.StoppingOrdinal <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "Based on a toxicity grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n")
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMaxGainCIRatio ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMaxGainCIRatio
knit_print.StoppingMaxGainCIRatio <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If the ratio of the upper to the lower limit of the posterior 95% credible ",
    "interval for the probability of toxicity at the target dose (the smaller ",
    "of the MTD for ",
    100 * x@prob_target,
    "% target and GStar) is less than or equal to ",
    x@target_ratio,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingList ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param preamble (`character`)\cr the text that introduces the list of rules
#' @param indent (`integer`)\cr the indent level of the current stopping rule
#'   list. Spaces with length `indent * 4` will be prepended to the beginning of
#'   the rendered stopping rule list.
#' @rdname knit_print
#' @export
#' @method knit_print StoppingList
knit_print.StoppingList <- function(
  x,
  ...,
  preamble,
  indent = 0L,
  asis = TRUE
) {
  assert_flag(asis)
  assert_integer(indent, lower = 0)

  if (missing(preamble)) {
    case_string <- switch(
      as.character(length(x@stop_list)),
      `1` = "rule ",
      "rules "
    )
    preamble <- paste0(
      "If the result of applying the summary function to the following ",
      case_string,
      "is `TRUE`:\n"
    )
  } else {
    assert_character(preamble, len = 1, any.missing = FALSE)
  }

  rules_list <- paste0(
    lapply(
      x@stop_list,
      function(z, indent) {
        paste0(
          strrep(" ", indent * 4),
          "-  ",
          knit_print(z, asis = FALSE, indent = indent + 1L, ...)
        )
      },
      indent = indent
    ),
    collapse = "\n"
  )
  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    preamble,
    "\n",
    rules_list,
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingAny ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingList
#' @rdname knit_print
#' @export
#' @method knit_print StoppingAny
knit_print.StoppingAny <- function(
  x,
  ...,
  preamble,
  asis = TRUE
) {
  if (missing(preamble)) {
    case_string <- switch(
      as.character(length(x@stop_list)),
      `1` = c("this ", "rule is "),
      `2` = c("either of the ", "rules are "),
      c("any of the ", "rules are ") # this works as default case
    )
    preamble <- paste0(
      "If ",
      case_string[1],
      "following ",
      case_string[2],
      "`TRUE`:\n"
    )
  }
  knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
}

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingList
#' @rdname knit_print
#' @export
#' @method knit_print StoppingAll
knit_print.StoppingAll <- function(
  x,
  ...,
  preamble,
  asis = TRUE
) {
  if (missing(preamble)) {
    case_string <- switch(
      as.character(length(x@stop_list)),
      `1` = c("this ", "rule is "),
      `2` = c("both of the ", "rules are "),
      c("all of the ", "rules are ") # this works as default case
    )
    preamble <- paste0(
      "If ",
      case_string[1],
      "following ",
      case_string[2],
      "`TRUE`:\n"
    )
  }
  knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
}

# StoppingTDCIRatio ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingTDCIRatio
knit_print.StoppingTDCIRatio <- function(
  x,
  ...,
  dose_label = "the next best dose",
  tox_label = "toxicity",
  fmt_string = paste0(
    "%sIf, at %s, the ratio of the upper to the lower limit of the posterior ",
    "95%% credible interval for %s (targetting %2.0f%%) is less than or equal to "
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(dose_label, len = 1, any.missing = FALSE)

  rv <- paste0(
    sprintf(
      fmt_string,
      ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
      dose_label,
      tox_label,
      100 * x@prob_target
    ),
    x@target_ratio,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingTargetBiomarker ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
#' @rdname knit_print
#' @export
#' @method knit_print StoppingTargetBiomarker
knit_print.StoppingTargetBiomarker <- function(
  x,
  ...,
  dose_label = "the next best dose",
  biomarker_label = "the target biomarker",
  fmt_string = paste0(
    "%sIf, at %s, the posterior probability that %s is in the range ",
    "(%.2f, %.2f)%s is %.0f%% or more.\n\n"
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)
  assert_character(biomarker_label, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    dose_label,
    biomarker_label,
    x@target[1],
    x@target[2],
    ifelse(
      x@is_relative,
      paste0(", relative to the maximum value of ", biomarker_label, ","),
      ""
    ),
    100 * x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingLowestDoseHSRBeta ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingLowestDoseHSRBeta
knit_print.StoppingLowestDoseHSRBeta <- function(
  x,
  ...,
  tox_label = "toxicity",
  fmt_string = paste0(
    "%sIf, using a Hard Stopping Rule with a prior of Beta(%.0f, %.0f), the ",
    "lowest dose in the dose grid has a posterior probability of %s of ",
    "%.0f%% or more.\n\n"
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    x@a,
    x@b,
    tox_label,
    100 * x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMTDCV ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMTDCV
knit_print.StoppingMTDCV <- function(
  x,
  ...,
  fmt_string = paste0(
    "%sIf the posterior estimate of the robust coefficient of variation of ",
    "the MTD (targetting %2.0f%%), is than or equal to %.0f%%.\n\n"
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    100 * x@target,
    100 * x@thresh_cv
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMTDdistribution ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMTDdistribution
knit_print.StoppingMTDdistribution <- function(
  x,
  ...,
  fmt_string = "%sIf the mean posterior probability of %s at %.0f%% of %s is at least %4.2f.\n\n",
  dose_label = "the next best dose",
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(dose_label, len = 1, any.missing = FALSE)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    tox_label,
    100 * x@thresh,
    dose_label,
    x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingHighestDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingHighestDose
knit_print.StoppingHighestDose <- function(
  x,
  ...,
  dose_label = "the highest dose in the dose grid",
  asis = TRUE
) {
  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If the next best dose is ",
    dose_label,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingSpecificDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingSpecificDose
knit_print.StoppingSpecificDose <- function(
  x,
  ...,
  dose_label = as.character(x@dose),
  asis = TRUE
) {
  x@rule@report_label <- x@report_label
  knit_print(
    x@rule,
    ...,
    dose_label = dose_label,
    asis = asis
  )
}

# StoppingTargetProb ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @param fmt_string (`character`)\cr the character string that defines the format
#' of the output
#' @param dose_label (`character`)\cr the term used to describe the target dose
#' @param tox_label (`character`)\cr the term used to describe toxicity
#' @rdname knit_print
#' @export
#' @method knit_print StoppingTargetProb
knit_print.StoppingTargetProb <- function(
  x,
  ...,
  fmt_string = paste0(
    "%sIf the probability of %s at %s is in the range [%4.2f, %4.2f] ",
    "is at least %4.2f.\n\n"
  ),
  dose_label = "the next best dose",
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(dose_label, len = 1, any.missing = FALSE)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    tox_label,
    dose_label,
    x@target[1],
    x@target[2],
    x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMinCohorts ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMinCohorts
knit_print.StoppingMinCohorts <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nCohorts,
    " or more cohorts have been treated.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMinPatients ----

#' @description `r lifecycle::badge("experimental")`
#' @param label (`character`)\cr the term used to label participants
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMinPatients
knit_print.StoppingMinPatients <- function(
  x,
  ...,
  label = "participant",
  asis = TRUE
) {
  assert_flag(asis)
  label <- h_prepare_labels(label)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nPatients,
    paste0(" or more ", label[2], " have been treated."),
    "\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingPatientsNearDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param label (`character`)\cr the term used to label participants
#' @inheritParams knit_print.StoppingTargetProb
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingPatientsNearDose
knit_print.StoppingPatientsNearDose <- function(
  x,
  ...,
  dose_label = "the next best dose",
  label = "participants",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(label, len = 1, any.missing = FALSE)
  assert_character(dose_label, len = 1, any.missing = FALSE)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nPatients,
    paste0(" or more ", label, " have been treated "),
    ifelse(
      x@percentage == 0,
      "at ",
      paste0("within ", x@percentage, "% of ")
    ),
    dose_label,
    ".\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingCohortsNearDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingCohortsNearDose
knit_print.StoppingCohortsNearDose <- function(
  x,
  ...,
  dose_label = "the next best dose",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(dose_label, len = 1, any.missing = FALSE)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nCohorts,
    " or more cohorts have been treated ",
    ifelse(
      x@percentage == 0,
      "at ",
      paste0("within ", x@percentage, "% of ")
    ),
    dose_label,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMissingDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMissingDose
knit_print.StoppingMissingDose <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If the dose returned by <code>nextBest()</code> is ",
    "<code>NA</code>, or if the trial includes a placebo dose, the placebo dose.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# Generics ----

#' Obtain a Text Representation of the Reference Dose
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`GeneralModel`)\cr the model object that will be printed
#' @param ... Not used at present
#' @return A character string containing a LaTeX rendition of the model.
#' @noRd
h_knit_print_render_ref_dose <- function(x, ...) {
  UseMethod("h_knit_print_render_ref_dose")
}

#' Render a Model Function in a `knit_print` Method
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`GeneralModel`)\cr the model object that will be printed
#' @param ... Not used at present
#' @return A character string containing a LaTeX rendition of the model.
#' @noRd
h_knit_print_render_model <- function(x, ...) {
  UseMethod("h_knit_print_render_model")
}

#' Obtain a Text Representation of a Biomarker Model
#'
#' This is a helper method used `knit_print` for `DualEndpoint` classes.
#'
#' @param x (`DualEndpoint`)\cr the model object containing the biomarker model
#' @param use_values (`flag`)\cr print the values associated with hyperparameters,
#' or the symbols used to define the hyper-parameters.  That is, for example, mu or 1.
#' @param ... Not used at present
#' @return A character string containing a LaTeX rendition of the model.
#' @noRd
h_knit_print_render_biomarker_model <- function(x, use_values = TRUE, ...) {
  UseMethod("h_knit_print_render_biomarker_model")
}

# Methods ----

# DualEndpoint ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param biomarker_label (`character`)\cr A description of the biomarker
#' @rdname knit_print
#' @export
#' @method knit_print DualEndpoint
knit_print.DualEndpoint <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA,
  tox_label = "toxicity",
  biomarker_label = "PD biomarker"
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Initialise
  biomarker_label <- h_prepare_labels(biomarker_label)
  tox_label <- h_prepare_labels(tox_label)
  units <- h_prepare_units(units)
  # Execute
  toxModel <- ProbitLogNormal(
    cov = x@betaZ_params@cov,
    mean = x@betaZ_params@mean,
    ref_dose = x@ref_dose
  )
  rv <- paste0(
    "The relationships between dose and ",
    tox_label[1],
    " and between dose and ",
    biomarker_label[1],
    " will be modelled simultaneously.\n\n",
    knit_print(
      toxModel,
      asis = asis,
      tox_label = tox_label,
      use_values = use_values,
      fmt = fmt,
      units = units,
      ...
    ),
    "\n\n",
    "The ",
    biomarker_label[1],
    " response `w` at dose `d` is modelled as ",
    "$$ w(d) \\sim N(f(d), \\sigma_w^2) $$ \n\nwhere ",
    h_knit_print_render_biomarker_model(x, use_values = use_values, ...)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpoint <- function(
  x,
  ...,
  use_values = TRUE
) {
  "f(d) is a function of dose that is defined elsewhere."
}

# DualEndpointBeta ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpointBeta <- function(x, ...) {
  paste0(
    "f(d) is a parametric rescaled beta density function such that\n\n",
    "$$ f(d) = ",
    "E_0 + (E_{max} - E_0) \\times Beta(\\delta_1, \\delta_2) \\times ",
    "\\left(\\frac{d}{d_{max}}\\right)^{\\delta_1}  \\times \\left(1 - ",
    "\\frac{d}{d_{max}}\\right)^{\\delta_2} $$\n\n",
    "where d~max~ is the maximum dose in the dose grid, &delta;~1~ and ",
    "&delta;~2~ are the parameters of the Beta function and ",
    "E~0~ and E~max~ are, respectively, the minimum and maximum levels of the ",
    "biomarker.  The mode can be written as \n\n",
    "$$ \\text{mode} = \\frac{\\delta_1}{\\delta_1 + \\delta_2} $$\n\n",
    " and this is the parameterisation used to define the model.\n\n",
    "In this case, \n\n",
    ifelse(
      length(x@E0) == 1,
      paste0("$$ E_0 = ", x@E0, " $$\n\n)"),
      paste0("$$ E_0  \\sim U(", x@E0[1], ", ", x@E0[2], ") $$\n\n")
    ),
    ifelse(
      length(x@Emax) == 1,
      paste0("$$ E_{max} = ", x@Emax, " $$\n\n)"),
      paste0("$$ E_{max}  \\sim U(", x@Emax[1], ", ", x@Emax[2], ") $$\n\n")
    ),
    ifelse(
      length(x@delta1) == 1,
      paste0("$$ \\delta_1 = ", x@delta1, " $$\n\n)"),
      paste0(
        "$$ \\delta_1  \\sim U(",
        x@delta1[1],
        ", ",
        x@delta1[2],
        ") $$\n\n"
      )
    ),
    ifelse(
      length(x@mode) == 1,
      paste0("$$ \\text{mode} = ", x@mode, " $$\n\n)"),
      paste0(
        "$$ \\text{mode}  \\sim U(",
        x@mode[1],
        ", ",
        x@mode[2],
        ") $$\n\n"
      )
    ),
    " and \n\n",
    ifelse(
      length(x@ref_dose_beta) == 1,
      paste0("$$ d_{max} = ", x@ref_dose_beta, " $$\n\n"),
      paste0(
        "$$ d_{max}  \\sim U(",
        x@ref_dose_beta[1],
        ", ",
        x@ref_dose_beta[2],
        ") $$\n\n"
      )
    )
  )
}

# DualEndpointEmax ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpointEmax <- function(x, ...) {
  paste0(
    "f(d) is a parametric Emax density function such that\n\n",
    "$$ f(d) = ",
    "E_0 + \\frac{(E_{max} - E_0) \\times \\frac{d}{d^*}}{\\text{ED}_{50} + \\frac{d}{d^*}} $$\n\n",
    "where d* is the reference dose, E~0~ and E~max~ are, respectively, the ",
    "minimum and maximum levels of the biomarker and ED~50~ is the dose achieving ",
    "half the maximum effect, 0.5 &times; E~max~.\n\n",
    "In this case, \n\n",
    ifelse(
      length(x@E0) == 1,
      paste0("$$ E_0 = ", x@E0, " $$\n\n)"),
      paste0("$$ E_0  \\sim U(", x@E0[1], ", ", x@E0[2], ") $$\n\n")
    ),
    ifelse(
      length(x@Emax) == 1,
      paste0("$$ E_{max} = ", x@Emax, " $$\n\n)"),
      paste0("$$ E_{max}  \\sim U(", x@Emax[1], ", ", x@Emax[2], ") $$\n\n")
    ),
    ifelse(
      length(x@ED50) == 1,
      paste0("$$ \\text{ED}_{50} = ", x@ED50, " $$\n\n)"),
      paste0(
        "$$ \\text{ED}_{50}  \\sim U(",
        x@ED50[1],
        ", ",
        x@ED50[2],
        ") $$\n\n"
      )
    ),
    " and \n\n",
    ifelse(
      length(x@ref_dose_emax) == 1,
      paste0("$$ d^* = ", x@ref_dose_emax, " $$\n\n"),
      paste0(
        "$$ d^* \\sim U(",
        x@ref_dose_emax[1],
        ", ",
        x@ref_dose_emax[2],
        ") $$\n\n"
      )
    )
  )
}

# DualEndpointRW ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpointRW <- function(
  x,
  ...,
  use_values = TRUE
) {
  paste0(
    "f(d) is a ",
    ifelse(x@rw1, "first", "second"),
    " order random walk such that\n\n",
    "$$ f(d) = ",
    "\\beta_{W_i} - \\beta_{W_{i - ",
    ifelse(x@rw1, "1", "2"),
    "}}",
    "\\sim N(0, ",
    ifelse(x@rw1, "", "2 \\times "),
    ifelse(
      use_values & length(x@sigma2betaW) == 1,
      x@sigma2betaW,
      "\\sigma_{\\beta_W}^2"
    ),
    " \\times (d_i - d_{i - ",
    ifelse(x@rw1, "1", "2"),
    "})",
    ")",
    " $$\n\n",
    ifelse(
      length(x@sigma2betaW) == 1,
      ifelse(
        use_values,
        "",
        paste0(" and $\\sigma_{\\beta_W}^2$ is fixed at ", x@sigma2betaW)
      ),
      paste0(
        " and the prior for $\\sigma_{\\beta_W}^2$ is an inverse-gamma distribution with parameters ",
        "a = ",
        x@sigma2betaW["a"],
        " and b = ",
        x@sigma2betaW["b"]
      )
    )
  )
}

# ModelParamsNormal ----

#' Render a Normal Prior
#'
#' @param x (`ModelParamsNormal`)\cr the object to be rendered
#' @param use_values (`flag`)\cr print the values associated with hyperparameters,
#' or the symbols used to define the hyper-parameters.  That is, for example, mu or 1.
#' @param fmt (`character`)\cr the `sprintf` format string used to render
#' numerical values.  Ignored if `use_values` is `FALSE`.
#' @param params (`character`)\cr The names of the model parameters.  See Usage
#' Notes below.
#' @param preamble (`character`)\cr The text used to introduce the LaTeX representation
#' of the model
#' @param asis (`flag`)\cr wrap the return value in a call to `knitr::asis_output`?
#' @param theta (`character`)\cr the LaTeX representation of the theta vector
#' @param ... Not used at present
#' @section Usage Notes:
#' `params` must be a character vector of length equal to that of `x@mean` (and
#' `x@cov`).  Its values represent the parameters of the model as entries in the
#' vector `theta`, on the left-hand side of "~" in the definition of the prior.
#' If named, names should be valid LaTeX, escaped as usual for R character variables.
#' For example, `"\\alpha"` or `"\\beta_0"`.  If unnamed, names are constructed by
#' pre-pending an escaped backslash to each value provided.
#' @return A character string containing a LaTeX rendition of the object.
#' @description `r lifecycle::badge("experimental")`
#' @export
#' @rdname knit_print
#' @method knit_print ModelParamsNormal
knit_print.ModelParamsNormal <- function(
  x,
  use_values = TRUE,
  fmt = "%5.2f",
  params = c("alpha", "beta"),
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE,
  theta = "\\theta",
  ...
) {
  # Validate
  assert_class(x, "ModelParamsNormal")
  assert_format(fmt)
  assert_character(preamble, len = 1)
  assert_true(length(x@mean) == length(params))
  assert_flag(asis)
  # Initialise
  n <- length(params)
  if (is.null(names(params))) {
    names(params) <- paste0("\\", params)
  }
  # Execute
  # Construct LaTeX representation of mean vector
  mu <- sapply(
    1:n,
    function(i) {
      ifelse(
        use_values,
        sprintf(fmt, x@mean[i]),
        paste0("\\mu_{\\", params[i], "}")
      )
    }
  )
  # Construct LaTeX representation of covariance matrix
  cov <- sapply(
    1:n,
    function(i) {
      sapply(
        1:n,
        function(j) {
          ifelse(
            use_values,
            sprintf(fmt, x@cov[i, j]),
            ifelse(
              i == j,
              paste0("\\sigma_{\\", params[i], "}^2"),
              paste0(
                "\\rho\\sigma_{\\",
                params[i],
                "}\\sigma_{\\",
                params[j],
                "}"
              )
            )
          )
        }
      )
    }
  )
  # Construct LaTeX representation of prior
  rv <- paste0(
    preamble,
    "$$ \\boldsymbol",
    theta,
    " = \\begin{bmatrix}",
    paste0(names(params), collapse = " \\\\ "),
    "\\end{bmatrix}",
    "\\sim N \\left(\\begin{bmatrix}",
    paste0(mu, collapse = " \\\\ "),
    "\\end{bmatrix} , ",
    "\\begin{bmatrix} ",
    paste0(
      sapply(
        1:n,
        function(j) {
          stringr::str_trim(paste0(cov[, j], collapse = " & "))
        }
      ),
      collapse = " \\\\ "
    ),
    "\\end{bmatrix}",
    " \\right)",
    " $$\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# GeneralModel ----

#' @export
#' @rdname knit_print
#' @method knit_print GeneralModel
knit_print.GeneralModel <- function(
  x,
  ...,
  params = c("alpha", "beta"),
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt, ...),
    knit_print(
      x@params,
      ...,
      asis = asis,
      use_values = use_values,
      fmt = fmt,
      params = params
    ),
    "\\n\\n",
    h_knit_print_render_ref_dose(
      x,
      use_values = use_values,
      fmt = fmt,
      unit = unit
    )
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @keywords internal
h_knit_print_render_ref_dose.GeneralModel <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_character(units, len = 1)
  # Initialise
  units <- h_prepare_units(units)
  # Execute
  ref_dose <- ifelse(
    use_values,
    paste0(
      " The reference dose will be ",
      stringr::str_trim(sprintf(fmt, x@ref_dose)),
      units,
      ".\n\n"
    ),
    ""
  )
  ref_dose
}

# LogisticKadane ----

#' @keywords internal
h_knit_print_render_ref_dose.LogisticKadane <- function(x, ...) {
  # The LogisticKadane class has no reference dose slot
  ""
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticKadane
knit_print.LogisticKadane <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA,
  tox_label = "toxicity"
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Initialise
  tox_label <- h_prepare_labels(tox_label)
  units <- h_prepare_units(units)
  # Execute
  rv <- paste0(
    "A logistic model using the parameterisation of Kadane (1980) will ",
    "describe the relationship between dose and ",
    tox_label[1],
    ".\n\n ",
    ifelse(
      use_values,
      paste0(
        "Let the minimum (x~min~) and maximum (x~max~) doses be ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmin)), units),
        " and ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmax)), units),
        ".\n\n"
      ),
      "Let x~min~ and x~max~ denote, respectively, the minimum and maximum doses.\n\n  "
    ),
    "Further, let &theta; denote the target toxicity rate and &rho;~0~ = p(DLT | D = x~min~).\n\n",
    "Let &gamma; be the dose with target toxicity rate &theta;, so that p(DLT | D = &gamma;) = &theta;",
    ifelse(
      use_values,
      paste0(" = ", x@theta, ".\n\n"),
      ".\n\n"
    ),
    "Using this parameterisation, standard logistic regression model has slope ",
    "$$ \\frac{\\gamma \\text{logit}(\\rho_0) - x_{min} \\text{logit}(\\theta)}{\\gamma - x_{min}} $$",
    " and intercept ",
    "$$ \\frac{\\text{logit}(\\theta) - logit(\\rho_0)}{\\gamma - x_{min}} $$",
    " The priors for &Gamma; and &Rho;~0~ are ",
    ifelse(
      use_values,
      paste0(
        "$$ \\Gamma \\sim U(",
        sprintf(fmt, x@xmin),
        ", ",
        sprintf(fmt, x@xmax),
        ") $$"
      ),
      "$$ \\Gamma \\sim U(x_{min}, x_{max}) $$"
    ),
    " and, independently, ",
    ifelse(
      use_values,
      paste0("$$ \\mathrm{P}_0 \\sim U(0, ", x@theta, ") $$"),
      "$$ \\mathrm{P}_0 \\sim U(0, \\theta) $$"
    ),
    "\n\n Note that x~min~ and x~max~ need not be equal to the smallest and ",
    "largest values in the `doseGrid` slot of the corresponding `Data` object.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticKadaneBetaGamma ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticKadaneBetaGamma
knit_print.LogisticKadaneBetaGamma <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  tox_label = "toxicity",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Initialise
  units <- h_prepare_units(units)
  tox_label <- h_prepare_labels(tox_label)
  # Execute
  rv <- paste0(
    "A logistic model using the parameterisation of Kadane (1980) will ",
    "describe the relationship between dose and ",
    tox_label[1],
    ", using a Beta ",
    "distribution as the prior for &rho;~0~ and a Gamma distribution as the prior ",
    "for &gamma;.\n\n ",
    ifelse(
      use_values,
      paste0(
        "Let the minimum (x~min~) and maximum (x~max~) doses be ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmin)), units),
        " and ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmax)), units),
        ".\n\n"
      ),
      "Let x~min~ and x~max~ denote, respectively, the minimum and maximum doses.\n\n  "
    ),
    "Further, let &theta; denote the target toxicity rate and &rho;~0~ = p(DLT | D = x~min~).\n\n",
    "Let &gamma; be the dose with target toxicity rate &theta;, so that p(DLT | D = &gamma;) = &theta;",
    ifelse(
      use_values,
      paste0(" = ", x@theta, ".\n\n"),
      ".\n\n"
    ),
    "Using this parameterisation, standard logistic regression model has slope ",
    "$$ \\frac{\\gamma \\text{logit}(\\rho_0) - x_{min} \\text{logit}(\\theta)}{\\gamma - x_{min}} $$",
    " and intercept ",
    "$$ \\frac{\\text{logit}(\\theta) - logit(\\rho_0)}{\\gamma - x_{min}} $$",
    " The priors for &Gamma; and &Rho;~0~ are ",
    ifelse(
      use_values,
      paste0(
        "$$ \\Gamma \\sim U(",
        sprintf(fmt, x@shape),
        ", ",
        sprintf(fmt, x@rate),
        ") $$"
      ),
      "$$ \\Gamma \\sim Gamma( \\text{shape}, \\text{rate}) $$"
    ),
    " and, independently, ",
    ifelse(
      use_values,
      paste0("$$ \\mathrm{P}_0 \\sim Beta(", x@alpha, ", ", x@beta, ") $$"),
      "$$ \\mathrm{P}_0 \\sim Beta(\\alpha, \\beta) $$"
    ),
    "\n\n Note that x~min~ and x~max~ need not be equal to the smallest and ",
    "largest values in the `doseGrid` slot of the corresponding `Data` object.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticLogNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormal <- function(
  x,
  tox_label = "toxicity",
  ...
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot log(d/d_{ref})}"
  paste0(
    "A logistic log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d~ref~ denotes a reference dose.\n\n"
  )
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormal
knit_print.LogisticLogNormal <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = c(
    "\\alpha" = "alpha",
    "log(\\beta)" = "beta"
  ),
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  assert_flag(asis)
  # Can't use NextMethod() on a S4 class
  knit_print.GeneralModel(
    x,
    ...,
    use_values = use_values,
    fmt = fmt,
    params = params,
    preamble = preamble,
    asis = asis
  )
}

# LogisticLogNormalMixture ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalMixture <- function(
  x,
  use_values = TRUE,
  tox_label = "toxicity",
  ...
) {
  tox_label <- h_prepare_labels(tox_label)
  z1 <- "e^{\\alpha_1 + \\beta_1 \\cdot log(d/d^*)}"
  z2 <- "e^{\\alpha_2 + \\beta_2 \\cdot log(d/d^*)}"
  pi_text <- ifelse(
    use_values,
    x@share_weight,
    "\\pi"
  )
  paste0(
    "A mixture of two logistic log normal models will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = ",
    pi_text,
    " \\times \\frac{",
    z1,
    "}{1 + ",
    z1,
    "} + (1 - ",
    pi_text,
    ") \\times \\frac{",
    z2,
    "}{1 + ",
    z2,
    "} $$",
    ifelse(
      use_values,
      "where d* denotes a reference dose.\n\n",
      "where d* denotes a reference dose and &pi; is a fixed value between 0 and 1.\n\n"
    )
  )
}

#' @export
#' @rdname knit_print
#' @method knit_print LogisticLogNormalMixture
knit_print.LogisticLogNormalMixture <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt, ...),
    knit_print(
      x@params,
      ...,
      asis = asis,
      use_values = use_values,
      fmt = fmt,
      preamble = "The priors for both &theta;~1~ and &theta;~2~ are given by\\n"
    ),
    "\\n\\n",
    h_knit_print_render_ref_dose(
      x,
      use_values = use_values,
      fmt = fmt,
      unit = unit
    )
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticLogNormalSub ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalSub <- function(
  x,
  ...,
  tox_label = "toxicity"
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot (d \\, - \\, d^*)}"
  paste0(
    "A logistic log normal model with subtractive dose normalisation will ",
    "describe the relationship between dose and ",
    tox_label[1],
    ": \n\n",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormalSub
knit_print.LogisticLogNormalSub <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = c(
    "\\alpha" = "alpha",
    "log(\\beta)" = "beta"
  ),
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  NextMethod(params = params)
}

# LogisticNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticNormal <- function(
  x,
  ...,
  tox_label = "toxicity"
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot d/d^*}"
  paste0(
    "A logistic log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# ProbitLogNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.ProbitLogNormal <- function(
  x,
  tox_label = "toxicity",
  ...
) {
  tox_label <- h_prepare_labels(tox_label)
  paste0(
    "A probit log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ \\Phi^{-1}(Tox | d) = f(X = 1 | \\theta, d) = \\alpha + \\beta \\cdot log(d/d^*) $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# ProbitLogNormalRel ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.ProbitLogNormalRel <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  tox_label <- h_prepare_labels(tox_label)
  paste0(
    "A probit log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ \\Phi^{-1}(Tox | d) = f(X = 1 | \\theta, d) = \\alpha + \\beta \\cdot d/d^* $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# LogisticNormalMixture ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticNormalMixture <- function(
  x,
  ...,
  tox_label = "toxicity"
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot log(d/d^*)}"
  paste0(
    "A mixture of two logistic log normal models will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

#' @export
#' @rdname knit_print
#' @method knit_print LogisticNormalMixture
knit_print.LogisticNormalMixture <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt, ...),
    "The prior for &theta; is given by\\n",
    "$$ \\theta = \\begin{bmatrix} \\alpha \\\\ log(\\beta) \\end{bmatrix}",
    " \\sim ",
    "w \\cdot ",
    knit_print(
      x@comp1,
      params = c("\\alpha" = "alpha", "\\beta" = "beta")
    ),
    " + (1 - w) \\cdot ",
    knit_print(
      x@comp2,
      params = c("\\alpha" = "alpha", "\\beta" = "beta")
    ),
    " $$\\n\\n",
    " and the prior for w is given by \n\n",
    " $$ w \\sim Beta(",
    x@weightpar[1],
    ", ",
    x@weightpar[2],
    ") $$\\n\\n",
    h_knit_print_render_ref_dose(
      x,
      units = units,
      fmt = fmt,
      use_values = use_values,
      ...
    )
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticNormalFixedMixture ----

#' @export
#' @rdname knit_print
#' @method knit_print LogisticNormalFixedMixture
knit_print.LogisticNormalFixedMixture <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  beta <- ifelse(x@log_normal, "log(\\beta)", "\\beta")
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt, ...),
    " The prior for &theta; is given by\\n\\n",
    "$$ \\theta = \\begin{bmatrix} \\alpha \\\\ ",
    beta,
    " \\end{bmatrix}",
    " \\sim \\sum_{i=1}^{",
    length(x@components),
    "}",
    "w_i \\cdot N \\left( \\mathbf{\\mu}_i ,  \\mathbf{\\Sigma}_i \\right)",
    " $$ \\n\\n",
    " with \\n\\n",
    "$$ \\sum_{i=1}^{",
    length(x@components),
    "} w_i = 1 $$ \\n\\n",
    " The individual components of the mixture are "
  )
  if (x@log_normal) {
    params <- c("\\alpha" = "alpha", "log(\\beta)" = "beta")
  } else {
    params <- c("\\alpha" = "alpha", "\\beta" = "beta")
  }
  for (i in seq_along(x@components)) {
    comp <- x@components[[i]]
    rv <- paste0(
      rv,
      knit_print(
        comp,
        params = params,
        preamble = " ",
        use_values = use_values,
        fmt = fmt,
        theta = paste0("\\theta_", i)
      ),
      " with weight ",
      x@weights[i],
      ifelse(
        i < length(x@components),
        " and",
        " "
      )
    )
  }
  rv <- paste0(
    rv,
    " \\n\\n ",
    h_knit_print_render_ref_dose(
      x,
      units = units,
      fmt = fmt,
      use_values = use_values,
      ...
    )
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticNormalFixedMixture <- function(
  x,
  ...,
  tox_label = "toxicity"
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot log(d/d^*)}"
  paste0(
    "A mixture of ",
    length(x@components),
    " logistic log normal models with fixed weights will describe the relationship ",
    "between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# ModelLogNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.ModelLogNormal <- function(x, ...) {
  "The model used to characterise the dose toxicity relationship is defined in  subclasses.\n\n"
}

# OneParLogNormalPrior ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print OneParLogNormalPrior
knit_print.OneParLogNormalPrior <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f"
) {
  assert_flag(asis)

  tox_label <- h_prepare_labels(tox_label)
  s2text <- ifelse(
    use_values,
    stringr::str_trim(sprintf(fmt, x@sigma2)),
    "\\sigma^2"
  )
  rv <- paste0(
    "The relationship between dose and ",
    tox_label[1],
    " will be modelled using a version ",
    "of the one parameter CRM of O'Quigley et al (1990) with an exponential prior on the ",
    "power parameter for the skeleton prior probabilities, with",
    ifelse(
      use_values,
      paste0("$$ \\Theta \\sim Exp(", s2text, ") $$"),
      "$$ \\Theta \\sim Exp(\\lambda) $$"
    ),
    "and skeleton probabilities as in the table below.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# OneParExpPrior ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print OneParExpPrior
knit_print.OneParExpPrior <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  rv <- "TODO\n\n"
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticLogNormalGrouped ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormalGrouped
knit_print.LogisticLogNormalGrouped <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = c(
    "\\alpha" = "alpha",
    "\\beta" = "beta",
    "log(\\delta_0)" = "delta_0",
    "log(\\delta_1)" = "delta_1"
  ),
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  NextMethod(params = params)
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalGrouped <- function(
  x,
  tox_label = "toxicity",
  ...
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{(\\alpha + I_c \\times \\delta_0) + (\\beta  + I_c \\times \\delta_1) \\cdot log(d/d^*)}"
  paste0(
    "A logistic log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose and I~c~ is a binary indicator which ",
    "is 1 for the combo arm and 0 for the mono arm.\n\n"
  )
}

# LogisticLogNormalOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalOrdinal <- function(x, ...) {
  z <- "e^{\\alpha_k + \\beta \\cdot log(d/d^*)}"
  paste0(
    "Let p~k~(d) be the probability that the response of a patient treated at ",
    "dose d is in category k *_or higher_*, k=0, ..., K; d=1, ..., D.\n\nThen ",
    "$$ p_k(d) = f(X \\ge k \\; | \\; \\theta, d) = \\begin{cases} 1 & k = 0 \\\\ ",
    "\\frac{",
    z,
    "}{1 + ",
    z,
    "} & k=1, ..., K",
    "\\end{cases} $$\n\n",
    "where d* denotes a reference dose.\n\nThe &alpha;s are constrained ",
    "such that &alpha;~1~ > &alpha;~2~ > ... > &alpha;~K~.\n\n"
  )
}

# LogisticLogNormalOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormalOrdinal
knit_print.LogisticLogNormalOrdinal <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = NA,
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  assert_flag(asis)
  if (is.na(params)) {
    params <- c(
      paste0("alpha_", 1:(length(x@params@mean) - 1)),
      "beta"
    )
    names(params) <- paste0("\\", params)
  }
  NextMethod(params = params)
}

# LogisticIndepBeta ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticIndepBeta
knit_print.LogisticIndepBeta <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = NA,
  tox_label = "DLAE",
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  assert_flag(asis)

  tox_label <- h_prepare_labels(tox_label)
  y <- tidy(x)
  z <- "e^{\\phi_1 + \\phi_2 \\cdot log(d)}"
  posterior <- ModelParamsNormal(mean = c(x@phi1, x@phi2), cov = x@Pcov)
  # knit_print.ModelParamsNormal expects no row or column names
  rownames(posterior@cov) <- NULL
  colnames(posterior@cov) <- NULL

  rv <- paste0(
    "A logistic log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "The prior is expressed in terms of pseudo data and, consequently, the number ",
    " of cases and of ",
    tox_label[2],
    " need not be whole numbers.\n\nThe pseudo data are ",
    "defined in the following table:\n\n",
    paste0(
      do.call(
        function(x) {
          kableExtra::kable_styling(
            knitr::kable(x, col.names = c("Dose", "N", tox_label[2])),
            bootstrap_options = c("striped", "hover", "condensed")
          )
        },
        list(x = y$pseudoData)
      ),
      collapse = "\n"
    ),
    ifelse(
      nrow(y$data) == 0,
      "\n\nNo observed data has yet been recorded.\n",
      paste(
        "\n\nThe observed data are given in the following table:\n\n",
        paste((do.call(knitr::kable, list(x = y$data))), collapse = "\n")
      )
    ),
    knit_print(
      posterior,
      preamble = paste0(
        "\n\nTogether, the pseudo and observed data give rise to ",
        "the following posterior for the model parameters:\n\n"
      ),
      params = c("\\phi_1" = "phi1", "\\phi_2" = "phi2"),
      theta = "\\phi",
      asis = FALSE,
      ...
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# Effloglog ----

#' @description `r lifecycle::badge("experimental")`
#' @param eff_label (`character`)\cr the term used to describe efficacy
#' @rdname knit_print
#' @export
#' @method knit_print Effloglog
knit_print.Effloglog <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = NA,
  tox_label = "DLAE",
  eff_label = "efficacy",
  label = "participant",
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(eff_label, len = 1, any.missing = FALSE)

  # Prepare
  tox_label <- h_prepare_labels(tox_label)
  eff_label <- h_prepare_labels(eff_label)
  label <- h_prepare_labels(label)

  y <- tidy(x)
  # knit_print.ModelParamsNormal expects no row or column names
  posterior <- ModelParamsNormal(mean = c(x@theta1, x@theta2), cov = x@Q)
  rownames(posterior@cov) <- NULL
  colnames(posterior@cov) <- NULL

  rv <- paste0(
    "A linear log-log model with a pseudo data prior will describe the ",
    "relationship between dose and ",
    eff_label[1],
    ".  The model is given by\n ",
    "$$ y_i = \\theta_1 + \\theta_2 \\cdot \\log(\\log(d_i + k)) + \\epsilon_i $$\\n ",
    "where k is a constant (equal to ",
    x@const,
    "), y~i~ is the ",
    eff_label[1],
    " response for ",
    label[1],
    " i, treated at dose d~i~ and &epsilon;~i~ is an error term.  ",
    "The &epsilon;s are iid N(0, &nu;^-1^).\n\n  ",
    "The ",
    ifelse(
      length(x@nu) == 1,
      paste0(
        ifelse(nrow(y$data) == 0, "prior", "posterior"),
        " value of &nu; is ",
        x@nu,
        "."
      ),
      paste0(
        ifelse(nrow(y$data) == 0, "prior", "posterior"),
        " distribution of &nu; is currently &Gamma;(",
        sprintf(fmt, x@nu[1]),
        ", ",
        sprintf(fmt, x@nu[2]),
        ")."
      )
    ),
    "\n\nThe joint distribution of ",
    "&theta;~1~ and &theta;~2~ is given by\n\n",
    "$$ \\boldsymbol\\theta = \\begin{bmatrix}\\theta_1 \\\\ \\theta_2\\end{bmatrix} ",
    "\\sim N\\left(\\mu, \\nu \\boldsymbol{Q}^\\intercal \\right) $$ \nwhere ",
    "$\\boldsymbol{Q} = \\boldsymbol{X_0}^\\intercal\\boldsymbol{X_0} + ",
    "\\boldsymbol{X}^\\intercal\\boldsymbol{X}$ and **X~0~** is a design matrix ",
    "based on the dose levels in the pseudo data and **X** is a design matrix ",
    "based on the dose levels of ",
    label[2],
    "' no-",
    tox_label[1],
    " ",
    eff_label[1],
    " responses in the observed data, if any.\n\n",
    ifelse(
      nrow(y$data) == 0,
      "\n\nNo observed data has yet been recorded.\n",
      paste(
        "\n\nThe data observed to date are given in the following table:\n\n",
        paste(
          (do.call(
            function(z) {
              z %>%
                dplyr::select(-c(NObs, NGrid, DoseGrid, XLevel)) %>%
                knitr::kable() %>%
                kableExtra::kable_styling(
                  bootstrap_options = c("striped", "hover", "condensed")
                )
            },
            list(z = y$data)
          )),
          collapse = "\n"
        )
      )
    ),
    knit_print(
      posterior,
      preamble = paste0(
        "\n\nTogether, the pseudo and observed data give rise to ",
        "the following posterior for the model parameters:\n\n"
      ),
      params = c("\\theta_1" = "theta1", "\\theta_2" = "theta2"),
      asis = FALSE,
      ...
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @include checkmate.R
#' @include Model-methods.R
#' @include Samples-class.R
#' @include Rules-class.R
#' @include helpers.R
#' @include helpers_rules.R
#' @include helpers_broom.R
NULL

# nextBest ----

## generic ----

#' Finding the Next Best Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the recommended next best dose based on the
#' corresponding rule `nextBest`, the posterior `samples` from the `model` and
#' the underlying `data`.
#'
#' @param nextBest (`NextBest`)\cr the rule for the next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose. If it is an
#'   infinity (default), then essentially no dose limit will be applied in the
#'   course of dose recommendation calculation.
#' @param samples (`Samples`)\cr posterior samples from `model` parameters given
#'   `data`.
#' @param model (`GeneralModel`)\cr model that was used to generate the samples.
#' @param data (`Data`)\cr data that was used to generate the samples.
#' @param ... additional arguments without method dispatch.
#'
#' @return A list with the next best dose recommendation  (element named `value`)
#'   from the grid defined in `data`, and a plot depicting this recommendation
#'   (element named `plot`). In case of multiple plots also an element
#'   named `singlePlots` is included. The `singlePlots` is itself a list with
#'   single plots. An additional list with elements describing the outcome
#'   of the rule can be contained too.
#'
#' @export
#'
setGeneric(
  name = "nextBest",
  def = function(nextBest, doselimit, samples, model, data, ...) {
    if (!missing(doselimit)) {
      assert_number(doselimit, lower = 0, finite = FALSE)
    }
    standardGeneric("nextBest")
  },
  valueClass = "list"
)

#' @describeIn nextBest find the next best dose based on the EWOC rule.
#'
#' @aliases nextBest-NextBestEWOC
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestEWOC.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestEWOC",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )

    # Estimates of posterior probabilities that are based on the prob. samples
    # which are within overdose/target interval.
    prob_overdose <- colMeans(h_in_range(
      prob_samples,
      nextBest@overdose,
      bounds_closed = c(FALSE, TRUE)
    ))

    # Eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    is_dose_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo,
      levels = TRUE
    ) &
      (prob_overdose <= nextBest@max_overdose_prob)

    next_dose <- if (any(is_dose_eligible)) {
      # Take the highest eligible dose.
      next_best_level <- sum(is_dose_eligible)
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plot for the overdosing probability.
    p <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_overdose * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(
        yintercept = nextBest@max_overdose_prob * 100,
        lwd = 1.1,
        lty = 2,
        colour = "black"
      ) +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    list(
      value = next_dose,
      plot = p,
      singlePlots = list(overdose = p),
      probs = cbind(
        dose = data@doseGrid,
        overdose = prob_overdose
      )
    )
  }
)


## NextBestMTD ----

#' @describeIn nextBest find the next best dose based on the MTD rule.
#'
#' @aliases nextBest-NextBestMTD
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMTD.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMTD",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Generate the MTD samples and derive the next best dose.
    dose_target_samples <- dose(x = nextBest@target, model, samples, ...)
    dose_target <- nextBest@derive(dose_target_samples)

    # Round to the next possible grid point.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level]

    # Create a plot.
    p <- ggplot(
      data = data.frame(x = dose_target_samples),
      aes(.data$x)
    ) +
      geom_density(colour = "grey50") +
      coord_cartesian(xlim = range(data@doseGrid)) +
      geom_vline(xintercept = dose_target, colour = "black", lwd = 1.1) +
      geom_text(
        data = data.frame(x = dose_target),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = 0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("MTD") +
      ylab("Posterior density")

    if (is.finite(doselimit)) {
      p <- p +
        geom_vline(xintercept = doselimit, colour = "red", lwd = 1.1) +
        geom_text(
          data = data.frame(x = doselimit),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -0.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
      geom_text(
        data = data.frame(x = next_dose),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -1.5,
        colour = "blue",
        angle = 90
      )

    list(value = next_dose, plot = p)
  }
)

## NextBestNCRM ----

#' @describeIn nextBest find the next best dose based on the NCRM method. The
#'   additional element `probs` in the output's list contains the target and
#'   overdosing probabilities (across all doses in the dose grid) used in the
#'   derivation of the next best dose.
#'
#' @aliases nextBest-NextBestNCRM
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRM.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestNCRM",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )

    # Estimates of posterior probabilities that are based on the prob. samples
    # which are within overdose/target interval.
    prob_overdose <- colMeans(h_in_range(
      prob_samples,
      nextBest@overdose,
      bounds_closed = c(FALSE, TRUE)
    ))
    prob_target <- colMeans(h_in_range(prob_samples, nextBest@target))

    # Eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    is_dose_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo,
      levels = TRUE
    ) &
      (prob_overdose <= nextBest@max_overdose_prob)

    next_dose <- if (any(is_dose_eligible)) {
      # If maximum target probability is higher than some numerical threshold,
      # then take that level, otherwise stick to the maximum level that is OK.
      # next_best_level is relative to eligible doses.
      next_best_level <- ifelse(
        test = any(prob_target[is_dose_eligible] > 0.05),
        yes = which.max(prob_target[is_dose_eligible]),
        no = sum(is_dose_eligible)
      )
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plots, first for the target probability.
    p1 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_target * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "darkgreen",
        fill = "darkgreen"
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      ylab(paste("Target probability [%]"))

    if (is.finite(doselimit)) {
      p1 <- p1 +
        geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
    }

    if (any(is_dose_eligible)) {
      p1 <- p1 +
        geom_vline(
          xintercept = data@doseGrid[sum(is_dose_eligible)],
          lwd = 1.1,
          lty = 2,
          colour = "red"
        ) +
        geom_point(
          data = data.frame(
            x = next_dose,
            y = prob_target[is_dose_eligible][next_best_level] * 100 + 0.03
          ),
          aes(x = x, y = y),
          size = 3,
          pch = 25,
          col = "red",
          bg = "red"
        )
    }

    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_overdose * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(
        yintercept = nextBest@max_overdose_prob * 100,
        lwd = 1.1,
        lty = 2,
        colour = "black"
      ) +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Place them below each other.
    plot_joint <- gridExtra::arrangeGrob(p1, p2, nrow = 2)

    list(
      value = next_dose,
      plot = plot_joint,
      singlePlots = list(plot1 = p1, plot2 = p2),
      probs = cbind(
        dose = data@doseGrid,
        target = prob_target,
        overdose = prob_overdose
      )
    )
  }
)

## NextBestNCRM-DataParts ----

#' @describeIn nextBest find the next best dose based on the NCRM method when
#'   two parts trial is used.
#'
#' @aliases nextBest-NextBestNCRM-DataParts
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRM-DataParts.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestNCRM",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "DataParts"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Exception when we are in part I or about to start part II!
    if (all(data@part == 1L)) {
      # Propose the highest possible dose (assuming that the dose limit came
      # from reasonable increments rule, i.e. incrementsRelativeParts).
      if (is.infinite(doselimit)) {
        stop("A finite doselimit needs to be specified for Part I.")
      }
      list(value = doselimit, plot = NULL)
    } else {
      # Otherwise we will just do the standard thing.
      callNextMethod(nextBest, doselimit, samples, model, data, ...)
    }
  }
)

## NextBestNCRMLoss ----

#' @describeIn nextBest find the next best dose based on the NCRM method and
#'   loss function.
#'
#' @aliases nextBest-NextBestNCRMLoss
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRMLoss.R
#'
setMethod(
  "nextBest",
  signature = signature(
    nextBest = "NextBestNCRMLoss",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )
    # Compute probabilities to be in target and overdose tox interval.
    prob_underdosing <- colMeans(prob_samples < nextBest@target[1])
    prob_target <- colMeans(h_in_range(prob_samples, nextBest@target))
    prob_overdose <- colMeans(h_in_range(
      prob_samples,
      nextBest@overdose,
      bounds_closed = c(FALSE, TRUE)
    ))
    prob_mean <- colMeans(prob_samples)
    prob_sd <- apply(prob_samples, 2, stats::sd)

    is_unacceptable_specified <- any(nextBest@unacceptable != c(1, 1))

    prob_mat <- if (!is_unacceptable_specified) {
      cbind(
        underdosing = prob_underdosing,
        target = prob_target,
        overdose = prob_overdose
      )
    } else {
      prob_unacceptable <- colMeans(
        h_in_range(
          prob_samples,
          nextBest@unacceptable,
          bounds_closed = c(FALSE, TRUE)
        )
      )
      prob_excessive <- prob_overdose
      prob_overdose <- prob_excessive + prob_unacceptable
      cbind(
        underdosing = prob_underdosing,
        target = prob_target,
        excessive = prob_excessive,
        unacceptable = prob_unacceptable
      )
    }

    posterior_loss <- as.vector(nextBest@losses %*% t(prob_mat))
    names(posterior_loss) <- data@doseGrid

    probs <- cbind(
      dose = data@doseGrid,
      prob_mat = prob_mat,
      mean = prob_mean,
      std_dev = prob_sd,
      posterior_loss = posterior_loss
    )

    # Eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    is_dose_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo,
      levels = TRUE
    ) &
      (prob_overdose < nextBest@max_overdose_prob)

    # Next best dose is the dose with the minimum loss function.
    next_dose <- if (any(is_dose_eligible)) {
      next_best_level <- which.min(posterior_loss[is_dose_eligible])
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plot.
    p <- h_next_best_ncrm_loss_plot(
      prob_mat = prob_mat,
      posterior_loss = posterior_loss,
      max_overdose_prob = nextBest@max_overdose_prob,
      dose_grid = data@doseGrid,
      max_eligible_dose_level = sum(is_dose_eligible),
      doselimit = doselimit,
      next_dose = next_dose,
      is_unacceptable_specified = is_unacceptable_specified
    )

    c(list(value = next_dose, probs = probs), p)
  }
)

## NextBestThreePlusThree ----

#' @describeIn nextBest find the next best dose based on the 3+3 method.
#'
#' @aliases nextBest-NextBestThreePlusThree
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestThreePlusThree.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestThreePlusThree",
    doselimit = "missing",
    samples = "missing",
    model = "missing",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # The last dose level tested (not necessarily the maximum one).
    last_level <- tail(data@xLevel, 1L)

    # Get number of patients per grid's dose and DLT rate at the last level.
    nPatients <- table(factor(data@x, levels = data@doseGrid))
    n_dlts_last_level <- sum(data@y[data@xLevel == last_level])
    dlt_rate_last_level <- n_dlts_last_level / nPatients[last_level]

    level_change <- if (dlt_rate_last_level < 1 / 3) {
      # Escalate it, unless this is the highest level or the higher dose was already tried.
      ifelse(
        (last_level == data@nGrid) || (nPatients[last_level + 1L] > 0),
        0L,
        1L
      )
    } else {
      # Rate is too high, deescalate it, unless an edge case of 1/3, where the decision
      # depends on the num. of patients: if >3, then deescalate it, otherwise stay.
      ifelse(
        (dlt_rate_last_level == 1 / 3) && (nPatients[last_level] <= 3L),
        0L,
        -1L
      )
    }
    next_dose_level <- last_level + level_change

    # Do we stop here? Only if we have no MTD, or the next level has been tried
    # enough (more than three patients already).
    if (next_dose_level == 0L) {
      next_dose <- NA
      stop_here <- TRUE
    } else {
      next_dose <- data@doseGrid[next_dose_level]
      stop_here <- nPatients[next_dose_level] > 3L
    }

    list(value = next_dose, stopHere = stop_here)
  }
)

## NextBestDualEndpoint ----

#' @describeIn nextBest find the next best dose based on the dual endpoint
#'   model. The additional list element `probs` contains the target and
#'   overdosing probabilities (across all doses in the dose grid) used in the
#'   derivation of the next best dose.
#'
#' @aliases nextBest-NextBestDualEndpoint
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestDualEndpoint.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestDualEndpoint",
    doselimit = "numeric",
    samples = "Samples",
    model = "DualEndpoint",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Biomarker samples at the dose grid points.
    biom_samples <- samples@data$betaW

    prob_target <- if (nextBest@target_relative) {
      # If 'Emax' parameter available, target biomarker level will be relative to 'Emax',
      # otherwise, it will be relative to the maximum biomarker level achieved
      # in dose range for a given sample.
      if ("Emax" %in% names(samples)) {
        lwr <- nextBest@target[1] * samples@data$Emax
        upr <- nextBest@target[2] * samples@data$Emax
        colMeans(apply(biom_samples, 2L, function(s) (s >= lwr) & (s <= upr)))
      } else {
        target_levels <- apply(biom_samples, 1L, function(x) {
          rng <- range(x)
          min(which(h_in_range(
            x,
            nextBest@target * diff(rng) + rng[1] + c(0, 1e-10),
            bounds_closed = c(FALSE, TRUE)
          )))
        })
        prob_target <- as.vector(table(factor(
          target_levels,
          levels = 1:data@nGrid
        )))
        prob_target / nrow(biom_samples)
      }
    } else {
      colMeans(h_in_range(biom_samples, nextBest@target))
    }

    # Now, compute probabilities to be in overdose tox interval, then flag
    # eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples
    )
    prob_overdose <- colMeans(h_in_range(
      prob_samples,
      nextBest@overdose,
      bounds_closed = c(FALSE, TRUE)
    ))

    is_dose_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo,
      levels = TRUE
    ) &
      (prob_overdose < nextBest@max_overdose_prob)

    next_dose <- if (any(is_dose_eligible)) {
      # If maximum target probability is higher the threshold, then take that
      # level, otherwise stick to the maximum level that is eligible.
      # next_dose_level is relative to eligible doses.
      next_dose_level <- ifelse(
        test = any(prob_target[is_dose_eligible] > nextBest@target_thresh),
        yes = which.max(prob_target[is_dose_eligible]),
        no = sum(is_dose_eligible)
      )
      data@doseGrid[is_dose_eligible][next_dose_level]
    } else {
      NA_real_
    }

    # Build plots, first for the target probability.
    p1 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_target * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "darkgreen",
        fill = "darkgreen"
      ) +
      ylim(c(0, 100)) +
      ylab(paste("Target probability [%]"))

    if (is.finite(doselimit)) {
      p1 <- p1 +
        geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
    }

    if (any(is_dose_eligible)) {
      p1 <- p1 +
        geom_vline(
          xintercept = data@doseGrid[sum(is_dose_eligible)],
          lwd = 1.1,
          lty = 2,
          colour = "red"
        ) +
        geom_point(
          data = data.frame(
            x = next_dose,
            y = prob_target[is_dose_eligible][next_dose_level] * 100 + 0.03
          ),
          aes(x = x, y = y),
          size = 3,
          pch = 25,
          col = "red",
          bg = "red"
        )
    }

    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_overdose * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(
        yintercept = nextBest@max_overdose_prob * 100,
        lwd = 1.1,
        lty = 2,
        colour = "black"
      ) +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Place them below each other.
    plot_joint <- gridExtra::arrangeGrob(p1, p2, nrow = 2)

    list(
      value = next_dose,
      plot = plot_joint,
      singlePlots = list(plot1 = p1, plot2 = p2),
      probs = cbind(
        dose = data@doseGrid,
        target = prob_target,
        overdose = prob_overdose
      )
    )
  }
)

## NextBestMinDist ----

#' @describeIn nextBest gives the dose which is below the dose limit and has an
#'   estimated DLT probability which is closest to the target dose.
#'
#' @aliases nextBest-NextBestMinDist
#'
#' @export
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMinDist",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )
    dlt_prob <- colMeans(prob_samples)

    # Determine the dose with the closest distance.
    dose_target <- data@doseGrid[which.min(abs(dlt_prob - nextBest@target))]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    p <- ggplot(
      data = data.frame(x = data@doseGrid, y = dlt_prob),
      aes(.data$x, .data$y)
    ) +
      geom_line(colour = "grey50") +
      geom_point(fill = "grey50", colour = "grey50") +
      coord_cartesian(xlim = range(data@doseGrid)) +
      scale_x_continuous(
        labels = as.character(data@doseGrid),
        breaks = data@doseGrid,
        guide = guide_axis(check.overlap = TRUE)
      ) +
      geom_hline(yintercept = nextBest@target, linetype = "dotted") +
      geom_vline(xintercept = dose_target, colour = "black", lwd = 1.1) +
      geom_text(
        data = data.frame(x = dose_target),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = 0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab("Posterior toxicity probability")

    if (is.finite(doselimit)) {
      p <- p +
        geom_vline(xintercept = doselimit, colour = "red", lwd = 1.1) +
        geom_text(
          data = data.frame(x = doselimit),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -0.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
      geom_text(
        data = data.frame(x = next_dose),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -1.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      probs = cbind(dose = data@doseGrid, dlt_prob = dlt_prob),
      plot = p
    )
  }
)

## NextBestInfTheory ----

#' @describeIn nextBest gives the appropriate dose within an information
#'   theoretic framework.
#'
#' @aliases nextBest-NextBestInfTheory
#'
#' @export
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestInfTheory",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )

    criterion <- colMeans(h_info_theory_dist(
      prob_samples,
      nextBest@target,
      nextBest@asymmetry
    ))

    is_dose_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo,
      levels = TRUE
    )
    doses_eligible <- data@doseGrid[is_dose_eligible]
    next_best_level <- which.min(criterion[is_dose_eligible])
    next_best <- doses_eligible[next_best_level]
    list(value = next_best)
  }
)

## NextBestTD ----

#' @describeIn nextBest find the next best dose based only on the DLT responses
#'   and for [`LogisticIndepBeta`] model class object without DLT samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestTD
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestTD.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestTD",
    doselimit = "numeric",
    samples = "missing",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  definition = function(
    nextBest,
    doselimit = Inf,
    model,
    data,
    in_sim = FALSE,
    ...
  ) {
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Target dose estimates, i.e. the dose with probability of the occurrence of
    # a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt <- dose(x = prob_target_drt, model, ...)
    dose_target_eot <- dose(x = prob_target_eot, model, ...)

    # Find the next best doses in the doseGrid. The next best dose is the dose
    # at level closest and below the target dose estimate.
    # h_find_interval assumes that elements in doses_eligible are strictly increasing.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )

    next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
    next_dose_drt <- doses_eligible[next_dose_lev_drt]

    next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
    next_dose_eot <- doses_eligible[next_dose_lev_eot]

    # Find the variance of the log of the dose_target_eot.
    mat <- matrix(
      c(
        -1 / (model@phi2),
        -(log(prob_target_eot / (1 - prob_target_eot)) - model@phi1) /
          (model@phi2)^2
      ),
      nrow = 1
    )
    var_dose_target_eot <- as.vector(mat %*% model@Pcov %*% t(mat))

    # 95% credibility interval.
    ci_dose_target_eot <- exp(
      log(dose_target_eot) + c(-1, 1) * 1.96 * sqrt(var_dose_target_eot)
    )
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_td_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      data = data,
      prob_dlt = prob(dose = data@doseGrid, model = model, ...),
      doselimit = doselimit,
      next_dose = next_dose_drt
    )

    if (
      !h_in_range(
        dose_target_drt,
        range = dose_grid_range(data),
        bounds_closed = TRUE
      ) &&
        !in_sim
    ) {
      warning(paste(
        "TD",
        prob_target_drt * 100,
        "=",
        dose_target_drt,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(
        dose_target_eot,
        range = dose_grid_range(data),
        bounds_closed = TRUE
      ) &&
        !in_sim
    ) {
      warning(paste(
        "TD",
        prob_target_eot * 100,
        "=",
        dose_target_eot,
        "not within dose grid"
      ))
    }

    list(
      next_dose_drt = next_dose_drt,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_eot = next_dose_eot,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      plot = p
    )
  }
)

## NextBestTDsamples ----

#' @describeIn nextBest find the next best dose based only on the DLT responses
#'   and for [`LogisticIndepBeta`] model class object involving DLT samples.
#'
#' @aliases nextBest-NextBestTDsamples
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestTDsamples.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestTDsamples",
    doselimit = "numeric",
    samples = "Samples",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  definition = function(
    nextBest,
    doselimit = Inf,
    samples,
    model,
    data,
    in_sim,
    ...
  ) {
    # Generate target dose samples, i.e. the doses with probability of the
    # occurrence of a DLT that equals to the nextBest@prob_target_drt
    # (or nextBest@prob_target_eot, respectively).
    dose_target_drt_samples <- dose(
      x = nextBest@prob_target_drt,
      model,
      samples,
      ...
    )
    dose_target_eot_samples <- dose(
      x = nextBest@prob_target_eot,
      model,
      samples,
      ...
    )

    # Derive the prior/posterior estimates based on two above samples.
    dose_target_drt <- nextBest@derive(dose_target_drt_samples)
    dose_target_eot <- nextBest@derive(dose_target_eot_samples)

    # Find the next doses in the doseGrid. The next dose is the dose at level
    # closest and below the dose_target_drt (or dose_target_eot, respectively).
    # h_find_interval assumes that elements in doses_eligible are strictly increasing.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )

    next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
    next_dose_drt <- doses_eligible[next_dose_lev_drt]

    next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
    next_dose_eot <- doses_eligible[next_dose_lev_eot]

    # 95% credibility interval.
    ci_dose_target_eot <- as.numeric(quantile(
      dose_target_eot_samples,
      probs = c(0.025, 0.975)
    ))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_tdsamples_plot(
      dose_target_drt_samples = dose_target_drt_samples,
      dose_target_eot_samples = dose_target_eot_samples,
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_grid_range = range(data@doseGrid),
      nextBest = nextBest,
      doselimit = doselimit,
      next_dose = next_dose_drt
    )

    list(
      next_dose_drt = next_dose_drt,
      prob_target_drt = nextBest@prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_eot = next_dose_eot,
      prob_target_eot = nextBest@prob_target_eot,
      dose_target_eot = dose_target_eot,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      plot = p
    )
  }
)

## NextBestMaxGain ----

#' @describeIn nextBest find the next best dose based only on pseudo DLT model
#'   [`ModelTox`] and [`Effloglog`] efficacy model without samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestMaxGain
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMaxGain.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMaxGain",
    doselimit = "numeric",
    samples = "missing",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(
    nextBest,
    doselimit = Inf,
    model,
    data,
    model_eff,
    in_sim = FALSE,
    ...
  ) {
    assert_class(model_eff, "Effloglog")
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Target dose estimates, i.e. the dose with probability of the occurrence of
    # a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt <- dose(x = prob_target_drt, model, ...)
    dose_target_eot <- dose(x = prob_target_eot, model, ...)

    # Find the dose which gives the maximum gain.
    dosegrid_range <- dose_grid_range(data)
    opt <- optim(
      par = dosegrid_range[1],
      fn = function(DOSE) {
        -gain(DOSE, model_dle = model, model_eff = model_eff, ...)
      },
      method = "L-BFGS-B",
      lower = dosegrid_range[1],
      upper = dosegrid_range[2]
    )
    dose_mg <- opt$par # this is G*. # no lintr
    max_gain <- -opt$value

    # Print info message if dose target is outside of the range.
    if (
      !h_in_range(
        dose_target_drt,
        range = dose_grid_range(data),
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste(
        "Estimated TD",
        prob_target_drt * 100,
        "=",
        dose_target_drt,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(
        dose_target_eot,
        range = dose_grid_range(data),
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste(
        "Estimated TD",
        prob_target_eot * 100,
        "=",
        dose_target_eot,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(
        dose_mg,
        range = dose_grid_range(data),
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste("Estimated max gain dose =", dose_mg, "not within dose grid"))
    }

    # Get closest grid doses for a given target doses.
    nb_doses_at_grid <- h_next_best_mg_doses_at_grid(
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_grid = data@doseGrid,
      doselimit = doselimit,
      placebo = data@placebo
    )

    # 95% credibility intervals and corresponding ratios for maximum gain dose and target dose eot.
    ci <- h_next_best_mg_ci(
      dose_target = dose_target_eot,
      dose_mg = dose_mg,
      prob_target = prob_target_eot,
      placebo = data@placebo,
      model = model,
      model_eff = model_eff
    )

    # Build plot.
    p <- h_next_best_mg_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      max_gain = max_gain,
      next_dose = nb_doses_at_grid$next_dose,
      doselimit = doselimit,
      data = data,
      model = model,
      model_eff = model_eff
    )

    list(
      next_dose = nb_doses_at_grid$next_dose,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_drt = nb_doses_at_grid$next_dose_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      next_dose_eot = nb_doses_at_grid$next_dose_eot,
      dose_max_gain = dose_mg,
      next_dose_max_gain = nb_doses_at_grid$next_dose_mg,
      ci_dose_target_eot = ci$ci_dose_target,
      ci_ratio_dose_target_eot = ci$ci_ratio_dose_target,
      ci_dose_max_gain = ci$ci_dose_mg,
      ci_ratio_dose_max_gain = ci$ci_ratio_dose_mg,
      plot = p
    )
  }
)

## NextBestMaxGainSamples ----

#' @describeIn nextBest find the next best dose based on DLT and efficacy
#'   responses with DLT and efficacy samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog` or `EffFlexi`)\cr the efficacy model.
#' @param samples_eff (`Samples`)\cr posterior samples from `model_eff` parameters
#'   given `data`.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestMaxGainSamples
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMaxGainSamples.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMaxGainSamples",
    doselimit = "numeric",
    samples = "Samples",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(
    nextBest,
    doselimit = Inf,
    samples,
    model,
    data,
    model_eff,
    samples_eff,
    in_sim = FALSE,
    ...
  ) {
    assert_true(
      test_class(model_eff, "Effloglog") || test_class(model_eff, "EffFlexi")
    )
    assert_class(samples_eff, "Samples")
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Generate target dose samples, i.e. the doses with probability of the
    # occurrence of a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt_samples <- dose(
      x = prob_target_drt,
      model,
      samples = samples,
      ...
    )
    dose_target_eot_samples <- dose(
      x = prob_target_eot,
      model,
      samples = samples,
      ...
    )

    # Derive the prior/posterior estimates based on two above samples.
    dose_target_drt <- nextBest@derive(dose_target_drt_samples)
    dose_target_eot <- nextBest@derive(dose_target_eot_samples)

    # Gain samples.
    gain_samples <- sapply(
      data@doseGrid,
      gain,
      model,
      samples,
      model_eff,
      samples_eff,
      ...
    )
    # For every sample, get the dose (from the dose grid) that gives the maximum gain value.
    dose_lev_mg_samples <- apply(gain_samples, 1, which.max)
    dose_mg_samples <- data@doseGrid[dose_lev_mg_samples]
    # Maximum gain dose estimate is the nth percentile of the maximum gain dose samples.
    dose_mg <- nextBest@mg_derive(dose_mg_samples)
    gain_values <- apply(gain_samples, 2, FUN = nextBest@mg_derive)

    # Print info message if dose target is outside of the range.
    dosegrid_range <- dose_grid_range(data)
    if (
      !h_in_range(
        dose_target_drt,
        range = dosegrid_range,
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste(
        "Estimated TD",
        prob_target_drt * 100,
        "=",
        dose_target_drt,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(
        dose_target_eot,
        range = dosegrid_range,
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste(
        "Estimated TD",
        prob_target_eot * 100,
        "=",
        dose_target_eot,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(dose_mg, range = dosegrid_range, bounds_closed = FALSE) &&
        !in_sim
    ) {
      print(paste("Estimated max gain dose =", dose_mg, "not within dose grid"))
    }

    # Get closest grid doses for a given target doses.
    nb_doses_at_grid <- h_next_best_mg_doses_at_grid(
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_grid = data@doseGrid,
      doselimit = doselimit,
      placebo = data@placebo
    )

    # 95% credibility intervals and corresponding ratios for maximum gain dose and target dose eot.
    ci_dose_mg <- as.numeric(quantile(dose_mg_samples, probs = c(0.025, 0.975)))
    cir_dose_mg <- ci_dose_mg[2] / ci_dose_mg[1]

    ci_dose_target_eot <- as.numeric(quantile(
      dose_target_eot,
      probs = c(0.025, 0.975)
    ))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_mgsamples_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_mg_samples = dose_mg_samples,
      next_dose = nb_doses_at_grid$next_dose,
      doselimit = doselimit,
      dose_grid_range = dosegrid_range
    )

    list(
      next_dose = nb_doses_at_grid$next_dose,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_drt = nb_doses_at_grid$next_dose_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      next_dose_eot = nb_doses_at_grid$next_dose_eot,
      dose_max_gain = dose_mg,
      next_dose_max_gain = nb_doses_at_grid$next_dose_mg,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      ci_dose_max_gain = ci_dose_mg,
      ci_ratio_dose_max_gain = cir_dose_mg,
      plot = p
    )
  }
)

## NextBestProbMTDLTE ----

#' @describeIn nextBest find the next best dose based with the highest
#'  probability of having a toxicity rate less or equal to the target toxicity
#'  level.
#'
#' @aliases nextBest-NextBestProbMTDLTE
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestProbMTDLTE.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestProbMTDLTE",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )

    # Determine the maximum dose level with a toxicity probability below or
    # equal to the target and calculate how often a dose is selected as MTD
    # across iterations.
    # The first element of the vector is the relative frequency that no
    # dose in the grid is below or equal to the target, the
    # second element that the 1st dose of the grid is the MTD, etc..
    prob_mtd_lte <- prop.table(
      table(factor(
        rowSums(prob_samples <= nextBest@target),
        levels = 0:data@nGrid
      ))
    )

    allocation_crit <- as.vector(prob_mtd_lte)
    names(allocation_crit) <- as.character(c(0, data@doseGrid))

    # In case that placebo is used, placebo and the portion that is not assigned
    # to any dose of the grid are merged.
    if (data@placebo) {
      allocation_crit[1] <- sum(allocation_crit[1:2])
      allocation_crit <- allocation_crit[-2]
    }

    # Handling of the portion that is not assigned to an active dose of
    # the dose grid. The portion is added to the minimum active dose
    # of the dose grid.
    allocation_crit[2] <- sum(allocation_crit[1:2])
    allocation_crit <- allocation_crit[-1]

    # Determine the dose with the highest relative frequency.
    allocation_crit_dose <- as.numeric(names(allocation_crit))
    dose_target <- allocation_crit_dose[which.max(allocation_crit)]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    plt_data <- if (data@placebo && (data@doseGrid[1] == next_dose)) {
      data.frame(
        x = as.factor(data@doseGrid),
        y = c(0, as.numeric(allocation_crit)) * 100
      )
    } else {
      data.frame(
        x = as.factor(allocation_crit_dose),
        y = as.numeric(allocation_crit) * 100
      )
    }

    p <- ggplot(
      data = plt_data
    ) +
      geom_col(aes(x, y), fill = "grey75") +
      scale_x_discrete(drop = FALSE, guide = guide_axis(check.overlap = TRUE)) +
      geom_vline(
        xintercept = as.factor(dose_target),
        lwd = 1.1,
        colour = "black"
      ) +
      geom_text(
        data = data.frame(x = as.factor(dose_target)),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = -0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab(paste("Allocation criterion [%]"))

    if (is.finite(doselimit)) {
      doselimit_level <- if (sum(allocation_crit_dose == doselimit) > 0) {
        which(allocation_crit_dose == doselimit)
      } else {
        ifelse(
          test = data@placebo && (data@doseGrid[1] == next_dose),
          yes = 1.5,
          no = sum(allocation_crit_dose < doselimit) + 0.5
        )
      }

      p <- p +
        geom_vline(
          xintercept = doselimit_level,
          colour = "red",
          lwd = 1.1
        ) +
        geom_text(
          data = data.frame(x = doselimit_level),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -1.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(
        xintercept = as.factor(next_dose),
        colour = "blue",
        lwd = 1.1
      ) +
      geom_text(
        data = data.frame(x = as.factor(next_dose)),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -2.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      allocation = cbind(
        dose = allocation_crit_dose,
        allocation = allocation_crit
      ),
      plot = p
    )
  }
)

## NextBestProbMTDMinDist ----

#' @describeIn nextBest find the next best dose based with the highest
#'  probability of having a toxicity rate with minimum distance to the
#'  target toxicity level.
#'
#' @aliases nextBest-NextBestProbMTDMinDist
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestProbMtdMinDist.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestProbMTDMinDist",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )

    # Determine which dose level has the minimum distance to target.
    dose_min_mtd_dist <- apply(
      prob_samples,
      1,
      function(x) which.min(abs(x - nextBest@target))
    )

    allocation_crit <- prop.table(
      table(factor(dose_min_mtd_dist, levels = 1:data@nGrid))
    )
    names(allocation_crit) <- as.character(data@doseGrid)

    # In case that placebo is used, placebo and the first non-placebo dose
    # of the grid are merged.
    if (data@placebo) {
      allocation_crit[2] <- sum(allocation_crit[1:2])
      allocation_crit <- allocation_crit[-1]
    }

    # Determine the dose with the highest relative frequency.
    allocation_crit_dose <- as.numeric(names(allocation_crit))
    dose_target <- allocation_crit_dose[which.max(allocation_crit)]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    plt_data <- if (data@placebo && data@doseGrid[1] == next_dose) {
      data.frame(
        x = as.factor(data@doseGrid),
        y = c(0, as.numeric(allocation_crit)) * 100
      )
    } else {
      data.frame(
        x = as.factor(allocation_crit_dose),
        y = as.numeric(allocation_crit) * 100
      )
    }

    p <- ggplot(
      data = plt_data
    ) +
      geom_col(aes(x, y), fill = "grey75") +
      scale_x_discrete(guide = guide_axis(check.overlap = TRUE)) +
      geom_vline(
        xintercept = as.factor(dose_target),
        lwd = 1.1,
        colour = "black"
      ) +
      geom_text(
        data = data.frame(x = as.factor(dose_target)),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = -0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab(paste("Allocation criterion [%]"))

    if (is.finite(doselimit)) {
      doselimit_level <- if (any(allocation_crit_dose == doselimit)) {
        which(allocation_crit_dose == doselimit)
      } else {
        ifelse(
          test = data@placebo && data@doseGrid[1] == next_dose,
          yes = 1.5,
          no = sum(allocation_crit_dose < doselimit) + 0.5
        )
      }

      p <- p +
        geom_vline(
          xintercept = doselimit_level,
          colour = "red",
          lwd = 1.1
        ) +
        geom_text(
          data = data.frame(x = doselimit_level),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -1.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(
        xintercept = as.factor(next_dose),
        colour = "blue",
        lwd = 1.1
      ) +
      geom_text(
        data = data.frame(x = as.factor(next_dose)),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -2.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      allocation = cbind(
        dose = allocation_crit_dose,
        allocation = allocation_crit
      ),
      plot = p
    )
  }
)

## NextBestOrdinal ----

#' @describeIn nextBest find the next best dose for ordinal CRM models.
#'
#' @aliases nextBest-NextBestOrdinal
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestOrdinal.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestOrdinal",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    stop(
      paste0(
        "NextBestOrdinal objects can only be used with LogisticLogNormalOrdinal ",
        "models and DataOrdinal data objects. In this case, the model is a '",
        class(model),
        "' object and the data is in a ",
        class(data),
        " object."
      )
    )
  }
)

#' @describeIn nextBest find the next best dose for ordinal CRM models.
#'
#' @aliases nextBest-NextBestOrdinal
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestOrdinal.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestOrdinal",
    doselimit = "numeric",
    samples = "Samples",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    nextBest(
      nextBest = nextBest@rule,
      doselimit = doselimit,
      samples = h_convert_ordinal_samples(samples, nextBest@grade),
      model = h_convert_ordinal_model(model, nextBest@grade),
      data = h_convert_ordinal_data(data, nextBest@grade),
      ...
    )
  }
)

# maxDose ----

## generic ----

#' Determine the Maximum Possible Next Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function determines the upper limit of the next dose based on the
#' `increments`and the `data`.
#'
#' @param increments (`Increments`)\cr the rule for the next best dose.
#' @param data (`Data`)\cr input data.
#' @param ... additional arguments without method dispatch.
#'
#' @return A `number`, the maximum possible next dose.
#'
#' @export
#'
setGeneric(
  name = "maxDose",
  def = function(increments, data, ...) {
    standardGeneric("maxDose")
  },
  valueClass = "numeric"
)

## IncrementsRelative ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments.
#'
#' @aliases maxDose-IncrementsRelative
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelative.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelative",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    if (data@nObs == 0L) {
      # In this case we return Inf, because there is no restriction
      # from this stopping rule because we cannot reference any
      # previous dose. In practice this does not matter because
      # there is a starting dose fixed externally anyway.
      return(Inf)
    }
    last_dose <- data@x[data@nObs]
    # Determine in which interval the `last_dose` is.
    assert_true(last_dose >= head(increments@intervals, 1))
    last_dose_interval <- findInterval(
      x = last_dose,
      vec = increments@intervals
    )
    (1 + increments@increments[last_dose_interval]) * last_dose
  }
)

## IncrementsRelativeDLT ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments determined by DLTs so far.
#'
#' @aliases maxDose-IncrementsRelativeDLT
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeDLT.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeDLT",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    dlt_count <- sum(data@y)
    # Determine in which interval the `dlt_count` is.
    assert_true(dlt_count >= increments@intervals[1])
    dlt_count_interval <- findInterval(
      x = dlt_count,
      vec = increments@intervals
    )
    (1 + increments@increments[dlt_count_interval]) * data@x[data@nObs]
  }
)

## IncrementsRelativeDLTCurrent ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments determined by DLTs in the current cohort.
#'
#' @aliases maxDose-IncrementsRelativeDLTCurrent
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeDLTCurrent.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeDLTCurrent",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    last_dose <- data@x[data@nObs]

    # Determine how many DLTs have occurred in the last cohort.
    last_cohort <- data@cohort[data@nObs]
    last_cohort_indices <- which(data@cohort == last_cohort)
    dlt_count_lcohort <- sum(data@y[last_cohort_indices])

    # Determine in which interval the `dlt_count_lcohort` is.
    assert_true(dlt_count_lcohort >= increments@intervals[1])
    dlt_count_lcohort_int <- findInterval(
      x = dlt_count_lcohort,
      vec = increments@intervals
    )
    (1 + increments@increments[dlt_count_lcohort_int]) * last_dose
  }
)

## IncrementsRelativeParts ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments as well as part 1 and beginning of part 2.
#'
#' @aliases maxDose-IncrementsRelativeParts
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeParts.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeParts",
    data = "DataParts"
  ),
  definition = function(increments, data, ...) {
    all_in_part1 <- all(data@part == 1L)
    incrmnt <- if (all_in_part1) {
      part2_started <- data@nextPart == 2L
      if (part2_started) {
        any_dlt <- any(data@y == 1L)
        if (any_dlt) {
          increments@dlt_start
        } else if (increments@clean_start <= 0L) {
          increments@clean_start
        }
      } else {
        1L
      }
    }

    if (is.null(incrmnt)) {
      callNextMethod(increments, data, ...)
    } else {
      max_dose_lev_part1 <- match_within_tolerance(
        max(data@x),
        data@part1Ladder
      )
      new_max_dose_level <- max_dose_lev_part1 + incrmnt
      assert_true(new_max_dose_level >= 0L)
      assert_true(new_max_dose_level <= length(data@part1Ladder))
      data@part1Ladder[new_max_dose_level]
    }
  }
)

## IncrementsDoseLevels ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   the number of dose grid levels. That is, the max dose is determined as
#'   the one which level is equal to: base dose level + level increment.
#'   The base dose level is the level of the last dose in grid or the level
#'   of the maximum dose applied, which is defined in `increments` object.
#'   Find out more in [`IncrementsDoseLevels`].
#'
#' @aliases maxDose-IncrementsDoseLevels
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsDoseLevels.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsDoseLevels",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    # Determine what is the basis level for increment,
    # i.e. the last dose or the max dose applied.
    basis_dose_level <- ifelse(
      increments@basis_level == "last",
      data@xLevel[data@nObs],
      max(data@xLevel)
    )
    max_dose_level <- min(basis_dose_level + increments@levels, data@nGrid)
    data@doseGrid[max_dose_level]
  }
)

## IncrementsHSRBeta ----

#' @describeIn maxDose determine the maximum possible next dose for escalation.
#'
#' @aliases maxDose-IncrementsHSRBeta
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsHSRBeta.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsHSRBeta",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    # Summary of observed data per dose level.
    y <- factor(data@y, levels = c("0", "1"))
    dlt_tab <- table(y, data@x)

    # Ignore placebo if applied.
    if (data@placebo == TRUE & min(data@x) == data@doseGrid[1]) {
      dlt_tab <- dlt_tab[, -1]
    }

    # Extract dose names as these get lost if only one dose available.
    non_plcb_doses <- unique(sort(as.numeric(colnames(dlt_tab))))

    # Toxicity probability per dose level.
    x <- dlt_tab[2, ]
    n <- apply(dlt_tab, 2, sum)
    tox_prob <- pbeta(
      increments@target,
      x + increments@a,
      n - x + increments@b,
      lower.tail = FALSE
    )

    # Return the min toxic dose level or maximum dose level if no dose is toxic,
    # while ignoring placebo.
    dose_tox <- if (sum(tox_prob > increments@prob) > 0) {
      min(non_plcb_doses[which(tox_prob > increments@prob)])
    } else {
      # Add small value to max dose, so that the max dose is always smaller.
      max(data@doseGrid) + 0.01
    }

    # Determine the next maximum possible dose.
    # In case that the first active dose is above probability threshold,
    # the first active dose is reported as maximum. I.e. in case that placebo is used,
    # the second dose is reported. Please note that this rule should be used together
    # with the hard safety stopping rule to avoid inconsistent results.
    max(
      data@doseGrid[data@doseGrid < dose_tox],
      data@doseGrid[data@placebo + 1]
    )
  }
)

## IncrementsMin ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   multiple increment rules, taking the minimum across individual increments.
#'
#' @aliases maxDose-IncrementsMin
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsMin.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMin",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    individual_results <- sapply(
      increments@increments_list,
      maxDose,
      data = data,
      ...
    )
    min(individual_results)
  }
)

#' @describeIn maxDose determine the maximum possible next dose based on
#'   multiple increment rules, taking the minimum across individual increments.
#'
#' @aliases maxDose-IncrementsMin
#'
#' @export
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMin",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, ...) {
    individual_results <- sapply(
      increments@increments_list,
      maxDose,
      data = data,
      ...
    )
    min(individual_results)
  }
)

## IncrementsOrdinal ----

#' @describeIn maxDose determine the maximum possible next dose in an ordinal
#' CRM trial
#'
#' @aliases maxDose-IncrementsOrdinal
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsOrdinal.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, ...) {
    maxDose(
      increments = increments@rule,
      data = h_convert_ordinal_data(
        data,
        increments@grade,
        ...
      )
    )
  }
)

## IncrementsMaxToxProb ----

#' @describeIn maxDose determine the maximum possible next dose based on the
#' probability of toxicity
#' @param model (`GeneralModel`)\cr The model on which probabilities will be based
#' @param samples (`Samples`)\cr The MCMC samples to which `model` will be applied
#'
#' @aliases maxDose-IncrementsMaxToxProb
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsMaxToxProb.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMaxToxProb",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, model, samples, ...) {
    assert_class(samples, "Samples")
    assert_true(length(increments@prob) == length(data@yCategories) - 1)
    nm <- utils::tail(names(data@yCategories), -1)
    assert_set_equal(names(increments@prob), nm)

    probs <- dplyr::bind_rows(
      lapply(
        seq_along(increments@prob),
        function(g) {
          fitted_probs <- fit(samples, model, data, grade = g, ...)
          safe_fitted_probs <- dplyr::filter(
            fitted_probs,
            middle < increments@prob[nm[g]]
          )
          highest_safe_fitted_prob <- utils::tail(safe_fitted_probs, 1)
        }
      )
    )
    min(probs$dose)
  }
)
#' @describeIn maxDose determine the maximum possible next dose based on the
#' probability of toxicity
#' @param model (`GeneralModel`)\cr The model on which probabilities will be based
#' @param samples (`Samples`)\cr The MCMC samples to which `model` will be applied
#'
#' @aliases maxDose-IncrementsMaxToxProb
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsMaxToxProb.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMaxToxProb",
    data = "Data"
  ),
  definition = function(increments, data, model, samples, ...) {
    assert_class(samples, "Samples")
    assert_true(length(increments@prob) == 1)

    fitted_prob <- fit(samples, model, data, ...)
    safe_fitted_prob <- dplyr::filter(fitted_prob, middle < increments@prob)
    highest_safe_fitted_prob <- utils::tail(safe_fitted_prob, 1)
    highest_safe_fitted_prob$dose
  }
)

## tidy-IncrementsMaxToxProb ----

#' @rdname tidy
#' @aliases tidy-IncrementsMaxToxProb
#' @example examples/Rules-method-tidyIncrementsMaxToxProb.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsMaxToxProb"),
  definition = function(x, ...) {
    grades <- names(x@prob)
    if (is.null(grades)) {
      grades <- "1"
    }
    tibble(
      Grade = grades,
      Prob = x@prob
    ) %>%
      h_tidy_class(x)
  }
)

# and-Stopping-Stopping ----

#' Combine Two Stopping Rules with AND
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining two atomic stopping rules.
#'
#' @param e1 (`Stopping`)\cr first stopping rule object.
#' @param e2 (`Stopping`)\cr second stopping rule object.
#'
#' @return The [`StoppingAll`] object.
#'
#' @aliases and-Stopping-Stopping
#' @example examples/Rules-method-and-stopping-stopping.R
#' @export
#'
setMethod(
  f = "&",
  signature = signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  definition = function(e1, e2) {
    StoppingAll(list(e1, e2))
  }
)

# and-StoppingAll-Stopping ----

#' Combine a Stopping List and an Atomic Stopping Rule with AND
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining a stopping list and an atomic stopping rule.
#'
#' @param e1 (`StoppingAll`)\cr stopping list object.
#' @param e2 (`Stopping`)\cr stopping rule object.
#'
#' @return The modified [`StoppingAll`] object.
#'
#' @aliases and-StoppingAll-Stopping
#' @example examples/Rules-method-and-stoppingAll-stopping.R
#' @export
#'
setMethod(
  f = "&",
  signature = signature(
    e1 = "StoppingAll",
    e2 = "Stopping"
  ),
  definition = function(e1, e2) {
    e1@stop_list <- c(
      e1@stop_list,
      e2
    )
    e1
  }
)

# and-Stopping-StoppingAll ----

#' Combine an Atomic Stopping Rule and a Stopping List with AND
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining an atomic stopping rule and a stopping list.
#'
#' @param e1 (`Stopping`)\cr stopping rule object.
#' @param e2 (`StoppingAll`)\cr stopping list object.
#'
#' @return The modified [`StoppingAll`] object.
#'
#' @aliases and-Stopping-StoppingAll
#' @example examples/Rules-method-and-stopping-stoppingAll.R
#' @export
#'
setMethod(
  f = "&",
  signature = signature(
    e1 = "Stopping",
    e2 = "StoppingAll"
  ),
  definition = function(e1, e2) {
    e2@stop_list <- c(
      e1,
      e2@stop_list
    )
    e2
  }
)

# or-Stopping-Stopping ----

#' Combine Two Stopping Rules with OR
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining two atomic stopping rules.
#'
#' @param e1 (`Stopping`)\cr first stopping rule object.
#' @param e2 (`Stopping`)\cr second stopping rule object.
#'
#' @return The [`StoppingAny`] object.
#'
#' @aliases |,Stopping,Stopping-method
#' @name or-Stopping-Stopping
#' @example examples/Rules-method-or-stopping-stopping.R
#' @export
#'
setMethod(
  f = "|",
  signature = signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  definition = function(e1, e2) {
    StoppingAny(list(e1, e2))
  }
)

# or-StoppingAny-Stopping ----

#' Combine a Stopping List and an Atomic Stopping Rule with OR
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining a stopping list and an atomic stopping rule.
#'
#' @param e1 (`StoppingAny`)\cr stopping list object.
#' @param e2 (`Stopping`)\cr stopping rule object.
#'
#' @return The modified [`StoppingAny`] object.
#'
#' @aliases |,StoppingAny,Stopping-method
#' @name or-StoppingAny-Stopping
#' @example examples/Rules-method-or-stoppingAny-stopping.R
#' @export
#'
setMethod(
  f = "|",
  signature = signature(
    e1 = "StoppingAny",
    e2 = "Stopping"
  ),
  definition = function(e1, e2) {
    e1@stop_list <- c(
      e1@stop_list,
      e2
    )
    e1
  }
)

# or-Stopping-StoppingAny ----

#' Combine an Atomic Stopping Rule and a Stopping List with OR
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining an atomic stopping rule and a stopping list.
#'
#' @param e1 (`Stopping`)\cr stopping rule object.
#' @param e2 (`StoppingAny`)\cr stopping list object.
#'
#' @return The modified [`StoppingAny`] object.
#'
#' @aliases |,Stopping,StoppingAny-method
#' @name or-Stopping-StoppingAny
#' @example examples/Rules-method-or-stopping-stoppingAny.R
#' @export
#'
setMethod(
  f = "|",
  signature = signature(
    e1 = "Stopping",
    e2 = "StoppingAny"
  ),
  definition = function(e1, e2) {
    e2@stop_list <- c(
      e1,
      e2@stop_list
    )
    e2
  }
)

# Stopping ----

## stopTrial ----

#' Stop the trial?
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function returns whether to stop the trial.
#'
#' @param stopping (`Stopping`)\cr the rule for stopping the trial.
#' @param dose the recommended next best dose.
#' @param samples (`Samples`)\cr the mcmc samples.
#' @param model (`GeneralModel`)\cr the model.
#' @param data (`Data`)\cr input data.
#' @param ... additional arguments without method dispatch.
#'
#' @return logical value: `TRUE` if the trial can be stopped, `FALSE`
#' otherwise. It should have an attribute `message` which gives the reason
#' for the decision.
#'
#' @export
#' @example examples/Rules-method-CombiningStoppingRulesAndOr.R
setGeneric(
  name = "stopTrial",
  def = function(stopping, dose, samples, model, data, ...) {
    standardGeneric("stopTrial")
  },
  valueClass = "logical"
)

## stopTrial-StoppingMissingDose ----

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingMissingDose
#' @example examples/Rules-method-stopTrial-StoppingMissingDose.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMissingDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    do_stop <- is.na(dose) || (data@placebo && dose == min(data@doseGrid))

    msg <- paste(
      "Next dose is",
      ifelse(
        do_stop,
        paste(
          ifelse(
            data@placebo && dose == min(data@doseGrid),
            "placebo dose",
            "NA"
          ),
          ", i.e., no active dose is safe enough according to the NextBest rule."
        ),
        "available at the dose grid."
      )
    )

    structure(do_stop, message = msg, report_label = stopping@report_label)
  }
)

## stopTrial-StoppingList ----

#' @describeIn stopTrial Stop based on multiple stopping rules.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingList
#' @example examples/Rules-method-stopTrial-StoppingList.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingList",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Evaluate the individual stopping rules in the list.
    individual_results <-
      if (missing(samples)) {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          model = model,
          data = data,
          ...
        )
      } else {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          samples = samples,
          model = model,
          data = data,
          ...
        )
      }

    # Summarize to obtain overall result.
    overall_result <- stopping@summary(as.logical(individual_results))

    # Retrieve individual text messages, but let them in the list structure.
    overall_text <- lapply(individual_results, attr, "message")

    structure(
      overall_result,
      message = overall_text,
      individual = individual_results
    )
  }
)

## stopTrial-StoppingAll ----

#' @describeIn stopTrial Stop based on fulfillment of all multiple stopping
#'   rules.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingAll
#' @example examples/Rules-method-stopTrial-StoppingAll.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingAll",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Evaluate the individual stopping rules in the list.
    individual_results <-
      if (missing(samples)) {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          model = model,
          data = data,
          ...
        )
      } else {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          samples = samples,
          model = model,
          data = data,
          ...
        )
      }

    # Summarize to obtain overall result.
    overall_result <- all(as.logical(individual_results))

    # Retrieve individual text messages, but let them in the list structure.
    overall_text <- lapply(individual_results, attr, "message")

    structure(
      overall_result,
      message = overall_text,
      individual = individual_results,
      report_label = stopping@report_label
    )
  }
)


## stopTrial-StoppingAny ----

#' @describeIn stopTrial Stop based on fulfillment of any stopping rule.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingAny
#' @example examples/Rules-method-stopTrial-StoppingAny.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingAny",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Evaluate the individual stopping rules in the list.
    individual_results <-
      if (missing(samples)) {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          model = model,
          data = data,
          ...
        )
      } else {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          samples = samples,
          model = model,
          data = data,
          ...
        )
      }

    # Summarize to obtain overall result.
    overall_result <- any(as.logical(individual_results))

    # Retrieve individual text messages, but let them in the list structure.
    overall_text <- lapply(individual_results, attr, "message")

    structure(
      overall_result,
      message = overall_text,
      individual = individual_results,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingCohortsNearDose ----

#' @describeIn stopTrial Stop based on number of cohorts near to next best
#'   dose.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingCohortsNearDose
#' @example examples/Rules-method-stopTrial-StoppingCohortsNearDose.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingCohortsNearDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Determine the range where the cohorts must lie in.
    lower <- (100 - stopping@percentage) / 100 * dose
    upper <- (100 + stopping@percentage) / 100 * dose

    # Which patients lie there?
    index_patients <- which((data@x >= lower) & (data@x <= upper))

    # How many cohorts?
    n_cohorts <- length(unique(data@cohort[index_patients]))

    # So can we stop?
    do_stop <- n_cohorts >= stopping@nCohorts

    # Generate message.
    text <- paste(
      n_cohorts,
      " cohorts lie within ",
      stopping@percentage,
      "% of the next best dose ",
      dose,
      ". This ",
      ifelse(do_stop, "reached", "is below"),
      " the required ",
      stopping@nCohorts,
      " cohorts",
      sep = ""
    )

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingPatientsNearDose ----

#' @describeIn stopTrial Stop based on number of patients near to next best
#'   dose.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingPatientsNearDose
#' @example examples/Rules-method-stopTrial-StoppingPatientsNearDose.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingPatientsNearDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Determine the range where the cohorts must lie in.
    lower <- (100 - stopping@percentage) / 100 * dose
    upper <- (100 + stopping@percentage) / 100 * dose

    # How many patients lie there?
    n_patients <- ifelse(
      is.na(dose),
      0,
      sum((data@x >= lower) & (data@x <= upper))
    )

    # So can we stop?
    do_stop <- n_patients >= stopping@nPatients

    # Generate message.
    text <- paste(
      n_patients,
      " patients lie within ",
      stopping@percentage,
      "% of the next best dose ",
      dose,
      ". This ",
      ifelse(do_stop, "reached", "is below"),
      " the required ",
      stopping@nPatients,
      " patients",
      sep = ""
    )

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingMinCohorts ----

#' @describeIn stopTrial Stop based on minimum number of cohorts.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingMinCohorts
#' @example examples/Rules-method-stopTrial-StoppingMinCohorts.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMinCohorts",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Determine number of cohorts.
    n_cohorts <- length(unique(data@cohort))

    # So can we stop?
    do_stop <- n_cohorts >= stopping@nCohorts

    # Generate message.
    text <-
      paste(
        "Number of cohorts is",
        n_cohorts,
        "and thus",
        ifelse(do_stop, "reached", "below"),
        "the prespecified minimum number",
        stopping@nCohorts
      )

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingMinPatients ----

#' @describeIn stopTrial Stop based on minimum number of patients.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingMinPatients
#' @example examples/Rules-method-stopTrial-StoppingMinPatients.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMinPatients",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # So can we stop?
    do_stop <- data@nObs >= stopping@nPatients

    # Generate message.
    text <-
      paste(
        "Number of patients is",
        data@nObs,
        "and thus",
        ifelse(do_stop, "reached", "below"),
        "the prespecified minimum number",
        stopping@nPatients
      )

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingTargetProb ----

#' @describeIn stopTrial Stop based on probability of target tox interval
#'
#' @aliases stopTrial-StoppingTargetProb
#' @example examples/Rules-method-stopTrial-StoppingTargetProb.R
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTargetProb",
    dose = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Compute probability to be in target interval.
    prob_target <- ifelse(
      is.na(dose),
      0,
      mean(
        prob(dose = dose, model, samples, ...) >= stopping@target[1] &
          prob(dose = dose, model, samples, ...) <= stopping@target[2]
      )
    )

    do_stop <- prob_target >= stopping@prob

    msg <- paste(
      "Probability for target toxicity is",
      round(prob_target * 100),
      "% for dose",
      dose,
      "and thus",
      ifelse(do_stop, "above", "below"),
      "the required",
      round(stopping@prob * 100),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingMTDdistribution ----

#' @describeIn stopTrial Stop based on MTD distribution.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingMTDdistribution
#' @example examples/Rules-method-stopTrial-StoppingMTDdistribution.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMTDdistribution",
    dose = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # First, generate the MTD samples.
    # Add prior data and samples to the function environment so that they can
    # be used.
    mtd_samples <- dose(
      x = stopping@target,
      model,
      samples,
      ...
    )

    # What is the absolute threshold?
    abs_thresh <- stopping@thresh * dose

    # What is the probability to be above this dose?
    prob <- ifelse(
      is.na(abs_thresh),
      0,
      mean(mtd_samples > abs_thresh)
    )

    # So can we stop?
    do_stop <- prob >= stopping@prob

    # Generate message.
    text <-
      paste(
        "Probability of MTD above",
        round(stopping@thresh * 100),
        "% of current dose",
        dose,
        "is",
        round(prob * 100),
        "% and thus",
        ifelse(do_stop, "greater than or equal to", "strictly less than"),
        "the required",
        round(stopping@prob * 100),
        "%"
      )

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingMTDCV ----

#' @rdname stopTrial
#'
#' @description Stopping rule based precision of the MTD estimation.
#'   The trial is stopped, when the MTD can be estimated with sufficient precision.
#'   The criteria is based on the robust coefficient of variation (CV) calculated
#'   from the posterior distribution.
#'   The robust CV is defined `mad(MTD) / median(MTD)`, where `mad` is the median
#'   absolute deviation.
#'
#' @aliases stopTrial-StoppingMTDCV
#' @example examples/Rules-method-stopTrial-StoppingMTDCV.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMTDCV",
    dose = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    mtd_samples <- dose(
      x = stopping@target,
      model,
      samples,
      ...
    )
    # CV of MTD expressed as percentage, derived based on MTD posterior samples.
    mtd_cv <- (mad(mtd_samples) / median(mtd_samples)) * 100
    do_stop <- mtd_cv <= stopping@thresh_cv

    msg <- paste(
      "CV of MTD is",
      round(mtd_cv),
      "% and thus",
      ifelse(do_stop, "below", "above"),
      "the required precision threshold of",
      round(stopping@thresh_cv),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingLowestDoseHSRBeta ----

#' @rdname stopTrial
#'
#' @description Stopping based based on the lowest non placebo dose. The trial is
#'  stopped when the lowest non placebo dose meets the Hard
#'  Safety Rule, i.e. it is deemed to be overly toxic. Stopping is based on the
#'  observed data at the lowest dose level using a Bin-Beta model
#'  based on DLT probability.
#'
#' @aliases stopTrial-StoppingLowestDoseHSRBeta
#' @example examples/Rules-method-stopTrial-StoppingLowestDoseHSRBeta.R
#' @export
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingLowestDoseHSRBeta",
    dose = "numeric",
    samples = "Samples"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Actual number of patients at first active dose.
    n <- sum(data@x == data@doseGrid[data@placebo + 1])

    # Determine toxicity probability of the first active dose.
    tox_prob_first_dose <-
      if (n > 0) {
        x <- sum(data@y[which(data@x == data@doseGrid[data@placebo + 1])])
        pbeta(
          stopping@target,
          x + stopping@a,
          n - x + stopping@b,
          lower.tail = FALSE
        )
      } else {
        0
      }

    do_stop <- tox_prob_first_dose > stopping@prob

    # generate message
    msg <- if (n == 0) {
      "Lowest active dose not tested, stopping rule not applied."
    } else {
      paste(
        "Probability that the lowest active dose of ",
        data@doseGrid[data@placebo + 1],
        " being toxic based on posterior Beta distribution using a Beta(",
        stopping@a,
        ",",
        stopping@b,
        ") prior is ",
        round(tox_prob_first_dose * 100),
        "% and thus ",
        ifelse(do_stop, "above", "below"),
        " the required ",
        round(stopping@prob * 100),
        "% threshold.",
        sep = ""
      )
    }

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingTargetBiomarker ----

#' @describeIn stopTrial Stop based on probability of targeting biomarker
#'
#' @aliases stopTrial-StoppingTargetBiomarker
#' @example examples/Rules-method-stopTrial-StoppingTargetBiomarker.R
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTargetBiomarker",
    dose = "numeric",
    samples = "Samples",
    model = "DualEndpoint",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Compute the target biomarker prob at this dose.
    # Get the biomarker level samples at the dose grid points.
    biom_level_samples <- biomarker(
      xLevel = seq_len(data@nGrid),
      model,
      samples,
      ...
    )

    # If target is relative to maximum.
    if (stopping@is_relative) {
      # If there is an 'Emax' parameter, target biomarker level will
      # be relative to 'Emax', otherwise will be relative to the
      # maximum biomarker level achieved in the given dose range.
      if ("Emax" %in% names(samples)) {
        # For each sample, look which dose is maximizing the
        # simultaneous probability to be in the target biomarker
        # range and below overdose toxicity.
        prob_target <- numeric(ncol(biom_level_samples))
        prob_target <- sapply(
          seq(1, ncol(biom_level_samples)),
          function(x) {
            sum(
              biom_level_samples[, x] >=
                stopping@target[1] * samples@data$Emax &
                biom_level_samples[, x] <=
                  stopping@target[2] * samples@data$Emax
            ) /
              nrow(biom_level_samples)
          }
        )
      } else {
        # For each sample, look which was the minimum dose giving
        # relative target level.
        targetIndex <- apply(
          biom_level_samples,
          1L,
          function(x) {
            rnx <- range(x)
            min(which(
              (x >= stopping@target[1] * diff(rnx) + rnx[1]) &
                (x <= stopping@target[2] * diff(rnx) + rnx[1] + 1e-10)
            ))
          }
        )
        prob_target <- numeric(ncol(biom_level_samples))
        tab <- table(targetIndex)
        prob_target[as.numeric(names(tab))] <- tab
        prob_target <- prob_target / nrow(biom_level_samples)
      }
    } else {
      # Otherwise the target is absolute.
      # For each sample, look which dose is maximizing the
      # simultaneous probability to be in the target biomarker
      # range and below overdose toxicity.
      prob_target <- numeric(ncol(biom_level_samples))
      prob_target <- sapply(
        seq(1, ncol(biom_level_samples)),
        function(x) {
          sum(
            biom_level_samples[, x] >= stopping@target[1] &
              biom_level_samples[, x] <= stopping@target[2]
          ) /
            nrow(biom_level_samples)
        }
      )
    }

    prob_target <- ifelse(
      is.na(dose),
      0,
      prob_target[which(data@doseGrid == dose)]
    )

    do_stop <- prob_target >= stopping@prob

    msg <- paste(
      "Probability for target biomarker is",
      round(prob_target * 100),
      "% for dose",
      dose,
      "and thus",
      ifelse(do_stop, "above", "below"),
      "the required",
      round(stopping@prob * 100),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingSpecificDose ----

#' @describeIn stopTrial if Stopping rule is met for specific dose of the planned
#' dose grid and not just for the default next best dose.
#'
#' @aliases stopTrial-StoppingSpecificDose
#'
#' @export
#' @example examples/Rules-method-stopTrial-StoppingSpecificDose.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingSpecificDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Specific dose must be a part of the dose grid.
    assert_subset(x = stopping@dose@.Data, choices = data@doseGrid)

    # Evaluate the original (wrapped) stopping rule at the specific dose.
    result <- stopTrial(
      stopping = stopping@rule,
      dose = stopping@dose@.Data,
      samples = samples,
      model = model,
      data = data,
      ...
    )
    # Correct the text message from the original stopping rule.
    attr(result, "message") <- gsub(
      pattern = "next best",
      replacement = "specific",
      x = attr(result, "message"),
      ignore.case = TRUE
    )

    attr(result, "report_label") <- stopping@report_label

    result
  }
)

## stopTrial-StoppingHighestDose ----

#' @describeIn stopTrial Stop when the highest dose is reached.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingHighestDose
#' @example examples/Rules-method-stopTrial-StoppingHighestDose.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingHighestDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    is_highest_dose <- ifelse(
      is.na(dose),
      FALSE,
      (dose == data@doseGrid[data@nGrid])
    )
    structure(
      is_highest_dose,
      message = paste(
        "Next best dose is",
        dose,
        "and thus",
        ifelse(is_highest_dose, "the", "not the"),
        "highest dose"
      ),
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingOrdinal ----

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingOrdinal
#' @example examples/Rules-method-stopTrial-StoppingOrdinal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingOrdinal",
    dose = "numeric",
    samples = "ANY",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    stopTrial(
      stopping = stopping@rule,
      dose = dose,
      samples = h_convert_ordinal_samples(samples, stopping@grade),
      model = h_convert_ordinal_model(model, stopping@grade),
      data = h_convert_ordinal_data(data, stopping@grade),
      ...
    )
  }
)

## stopTrial-StoppingOrdinal ----

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingOrdinal
#' @example examples/Rules-method-stopTrial-StoppingOrdinal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingOrdinal",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    stop(
      paste0(
        "StoppingOrdinal objects can only be used with LogisticLogNormalOrdinal ",
        "models and DataOrdinal data objects. In this case, the model is a '",
        class(model),
        "' object and the data is in a ",
        class(data),
        " object."
      )
    )
  }
)

## stopTrial-StoppingExternal ----

#' @describeIn stopTrial Stop based on an external flag.
#'
#' @description `r lifecycle::badge("experimental")`
#' @param external (`flag`)\cr whether to stop based on the external
#'   result or not.
#'
#' @aliases stopTrial-StoppingExternal
#' @example examples/Rules-method-stopTrial-StoppingExternal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingExternal",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, external, ...) {
    assert_flag(external)

    msg <- paste(
      "Based on external result",
      ifelse(external, "stop", "continue")
    )

    structure(
      external,
      message = msg,
      report_label = stopping@report_label
    )
  }
)


## stopTrial-StoppingTDCIRatio ----

#' @describeIn stopTrial Stop based on [`StoppingTDCIRatio`] class when
#'   reaching the target ratio of the upper to the lower 95% credibility
#'   interval of the estimate (TDtargetEndOfTrial). This is a stopping rule
#'   which incorporates only DLE responses and DLE samples are given.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingTDCIRatio
#' @example examples/Rules-method-stopTrialCITDsamples.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTDCIRatio",
    dose = "ANY",
    samples = "Samples",
    model = "ModelTox",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    assert_probability(stopping@prob_target)

    dose_target_samples <- dose(
      x = stopping@prob_target,
      model = model,
      samples = samples,
      ...
    )
    # 95% credibility interval.
    dose_target_ci <- quantile(dose_target_samples, probs = c(0.025, 0.975))
    dose_target_ci_ratio <- dose_target_ci[[2]] / dose_target_ci[[1]]

    do_stop <- dose_target_ci_ratio <= stopping@target_ratio
    text <- paste0(
      "95% CI is (",
      paste(dose_target_ci, collapse = ", "),
      "), Ratio = ",
      round(dose_target_ci_ratio, 4),
      " is ",
      ifelse(do_stop, "less than or equal to ", "greater than "),
      "target_ratio = ",
      stopping@target_ratio
    )
    structure(do_stop, message = text, report_label = stopping@report_label)
  }
)

## stopTrial-StoppingTDCIRatio ----

#' @describeIn stopTrial Stop based on [`StoppingTDCIRatio`] class when
#'   reaching the target ratio of the upper to the lower 95% credibility
#'   interval of the estimate (TDtargetEndOfTrial). This is a stopping rule
#'   which incorporates only DLE responses and no DLE samples are involved.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingTDCIRatio
#' @example examples/Rules-method-stopTrialCITD.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTDCIRatio",
    dose = "ANY",
    samples = "missing",
    model = "ModelTox",
    data = "ANY"
  ),
  definition = function(stopping, dose, model, data, ...) {
    assert_probability(stopping@prob_target)

    prob_target <- stopping@prob_target
    dose_target_samples <- dose(x = prob_target, model = model, ...)
    # Find the variance of the log of the dose_target_samples (eta).
    m1 <- matrix(
      c(
        -1 / (model@phi2),
        -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2
      ),
      1,
      2
    )
    m2 <- model@Pcov
    var_eta <- as.vector(m1 %*% m2 %*% t(m1))

    # Find the upper and lower limit of the 95% credibility interval.
    ci <- exp(log(dose_target_samples) + c(-1, 1) * 1.96 * sqrt(var_eta))
    ratio <- ci[2] / ci[1]

    # So can we stop?
    do_stop <- ratio <= stopping@target_ratio
    # Generate message.
    text <- paste(
      "95% CI is (",
      round(ci[1], 4),
      ",",
      round(ci[2], 4),
      "), Ratio =",
      round(ratio, 4),
      "is ",
      ifelse(do_stop, "is less than or equal to", "greater than"),
      "target_ratio =",
      stopping@target_ratio
    )
    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingMaxGainCIRatio ----

#' @describeIn stopTrial Stop based on reaching the target ratio of the upper
#'   to the lower 95% credibility interval of the estimate (the minimum of
#'   Gstar and TDtargetEndOfTrial). This is a stopping rule which incorporates
#'   DLE and efficacy responses and DLE and efficacy samples are also used.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param TDderive (`function`)\cr the function which derives from the input,
#'   a vector of the posterior samples called `TDsamples` of the dose which has
#'   the probability of the occurrence of DLE equals to either the
#'   targetDuringTrial or targetEndOfTrial, the final next best
#'   TDtargetDuringTrial (the dose with probability of the occurrence of DLE
#'   equals to the targetDuringTrial) and TDtargetEndOfTrial estimate.
#' @param Effmodel (`ModelEff`)\cr the efficacy model.
#' @param Effsamples (`Samples`)\cr the efficacy samples.
#' @param Gstarderive (`function`)\cr the function which derives from the input,
#'   a vector of the posterior Gstar (the dose which gives the maximum gain
#'   value) samples called `Gstarsamples`, the final next best Gstar estimate.
#'
#' @aliases stopTrial-StoppingMaxGainCIRatio
#' @example examples/Rules-method-stopTrialCIMaxGainSamples.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMaxGainCIRatio",
    dose = "ANY",
    samples = "Samples",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(
    stopping,
    dose,
    samples,
    model,
    data,
    TDderive,
    Effmodel,
    Effsamples,
    Gstarderive,
    ...
  ) {
    prob_target <- stopping@prob_target

    # Checks.
    assert_probability(prob_target)
    stopifnot(is(Effmodel, "ModelEff"))
    stopifnot(is(Effsamples, "Samples"))
    stopifnot(is.function(TDderive))
    stopifnot(is.function(Gstarderive))

    # Find the TDtarget End of Trial samples.
    td_target_end_of_trial_samples <- dose(
      x = prob_target,
      model = model,
      samples = samples,
      ...
    )
    # Find the TDtarget End of trial estimate.
    td_target_end_of_trial_estimate <- TDderive(td_target_end_of_trial_samples)

    # Find the gain value samples then the GstarSamples.
    points <- data@doseGrid

    gain_samples <- matrix(
      nrow = size(samples),
      ncol = length(points)
    )

    # Evaluate the probs, for all gain samples.
    for (i in seq_along(points)) {
      # Now we want to evaluate for the following dose.
      gain_samples[, i] <- gain(
        dose = points[i],
        model,
        samples,
        Effmodel,
        Effsamples,
        ...
      )
    }

    # Find the maximum gain value samples.
    max_gain_samples <- apply(gain_samples, 1, max)

    # Obtain Gstar samples, samples for the dose level which gives the maximum
    # gain value.
    index_g <- apply(gain_samples, 1, which.max)
    gstar_samples <- data@doseGrid[index_g]

    # Find the Gstar estimate.
    gstar <- Gstarderive(gstar_samples)
    # Find the 95% credibility interval of Gstar and its ratio of the upper to
    # the lower limit.
    ci_gstar <- quantile(gstar_samples, probs = c(0.025, 0.975))
    ratio_gstar <- as.numeric(ci_gstar[2] / ci_gstar[1])

    # Find the 95% credibility interval of TDtargetEndOfTrial and its ratio of
    # the upper to the lower limit.
    ci_tdeot <- quantile(
      td_target_end_of_trial_samples,
      probs = c(0.025, 0.975)
    )
    ratio_tdeot <- as.numeric(ci_tdeot[2] / ci_tdeot[1])

    # Find which is smaller (TDtargetEndOfTrialEstimate or Gstar).
    if (td_target_end_of_trial_estimate <= gstar) {
      # Find the upper and lower limit of the 95% credibility interval and its
      # ratio of the smaller.
      ci <- ci_tdeot
      ratio <- ratio_tdeot
      choose_td <- TRUE
    } else {
      ci <- ci_gstar
      ratio <- ratio_gstar
      choose_td <- FALSE
    }

    # So can we stop?
    do_stop <- ratio <= stopping@target_ratio
    # Generate message.
    text1 <- paste(
      "Gstar estimate is",
      round(gstar, 4),
      "with 95% CI (",
      round(ci_gstar[1], 4),
      ",",
      round(ci_gstar[2], 4),
      ") and its ratio =",
      round(ratio_gstar, 4)
    )
    text2 <- paste(
      "TDtargetEndOfTrial estimate is ",
      round(td_target_end_of_trial_estimate, 4),
      "with 95% CI (",
      round(ci_tdeot[1], 4),
      ",",
      round(ci_tdeot[2], 4),
      ") and its ratio=",
      round(ratio_tdeot, 4)
    )
    text3 <- paste(
      ifelse(choose_td, "TDtargetEndOfTrial estimate", "Gstar estimate"),
      "is smaller with ratio =",
      round(ratio, 4),
      " which is ",
      ifelse(do_stop, "is less than or equal to", "greater than"),
      "target_ratio =",
      stopping@target_ratio
    )
    text <- c(text1, text2, text3)
    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

#' @describeIn stopTrial Stop based on reaching the target ratio of the upper
#'   to the lower 95% credibility interval of the estimate (the minimum of
#'   Gstar and TDtargetEndOfTrial). This is a stopping rule which incorporates
#'   DLE and efficacy responses without DLE and efficacy samples involved.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingMaxGainCIRatio
#' @example examples/Rules-method-stopTrialCIMaxGain.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMaxGainCIRatio",
    dose = "ANY",
    samples = "missing",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(stopping, dose, model, data, Effmodel, ...) {
    prob_target <- stopping@prob_target

    # Checks.
    assert_probability(prob_target)
    stopifnot(is(Effmodel, "ModelEff"))

    # Find the TDtarget End of Trial.
    td_target_end_of_trial <- dose(
      x = prob_target,
      model = model,
      ...
    )

    # Find the dose with maximum gain value.
    gainfun <- function(dose_val) {
      -gain(dose_val, model_dle = model, model_eff = Effmodel, ...)
    }

    lowest_dose <- min(data@doseGrid)

    gstar <- (optim(
      lowest_dose,
      gainfun,
      method = "L-BFGS-B",
      lower = lowest_dose,
      upper = max(data@doseGrid)
    )$par)
    max_gain <- -(optim(
      lowest_dose,
      gainfun,
      method = "L-BFGS-B",
      lower = lowest_dose,
      upper = max(data@doseGrid)
    )$value)
    if (data@placebo) {
      log_gstar <- log(gstar + Effmodel@const)
    } else {
      log_gstar <- log(gstar)
    }

    # From paper (Yeung et. al 2015).
    mean_eff_gstar <- Effmodel@theta1 + Effmodel@theta2 * log(log_gstar)

    denom <- (model@phi2) * (mean_eff_gstar) * (1 + log_gstar * model@phi2)

    dgphi1 <- -(mean_eff_gstar * log_gstar * model@phi2 - Effmodel@theta2) /
      denom

    dgphi2 <- -((mean_eff_gstar) *
      log_gstar +
      mean_eff_gstar * (log_gstar)^2 * model@phi2 -
      Effmodel@theta2 * log_gstar) /
      denom

    dgtheta1 <- -(log_gstar * model@phi2) / denom

    dgtheta2 <- -(log_gstar *
      exp(model@phi1 + model@phi2 * log_gstar) *
      model@phi2 *
      log(log_gstar) -
      1 -
      exp(model@phi1 + model@phi2 * log_gstar)) /
      denom

    delta_g <- matrix(c(dgphi1, dgphi2, dgtheta1, dgtheta2), 4, 1)

    # Find the variance of the log Gstar.
    # First find the covariance matrix of all the parameters, phi1, phi2,
    # theta1 and theta2 such that phi1 and phi2 are independent of theta1 and
    # theta2.
    empty_matrix <- matrix(0, 2, 2)
    cov_beta <- cbind(
      rbind(model@Pcov, empty_matrix),
      rbind(empty_matrix, Effmodel@Pcov)
    )
    var_log_gstar <- as.vector(t(delta_g) %*% cov_beta %*% delta_g)

    # Find the upper and lower limit of the 95% credibility interval of Gstar.
    ci_gstar <- exp(log_gstar + c(-1, 1) * 1.96 * sqrt(var_log_gstar))

    # The ratio of the upper to the lower 95% credibility interval.
    ratio_gstar <- ci_gstar[2] / ci_gstar[1]

    # Find the variance of the log of the TDtargetEndOfTrial (eta).
    m1 <- matrix(
      c(
        -1 / (model@phi2),
        -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2
      ),
      1,
      2
    )
    m2 <- model@Pcov

    var_eta <- as.vector(m1 %*% m2 %*% t(m1))

    # Find the upper and lower limit of the 95% credibility interval of
    # TDtargetEndOfTrial.
    ci_tdeot <- exp(
      log(td_target_end_of_trial) + c(-1, 1) * 1.96 * sqrt(var_eta)
    )

    # The ratio of the upper to the lower 95% credibility interval.
    ratio_tdeot <- ci_tdeot[2] / ci_tdeot[1]

    if (gstar <= td_target_end_of_trial) {
      choose_td <- FALSE
      ci <- c()
      ci[2] <- ci_gstar[2]
      ci[1] <- ci_gstar[1]
      ratio <- ratio_gstar
    } else {
      choose_td <- TRUE
      ci <- c()
      ci[2] <- ci_tdeot[2]
      ci[1] <- ci_tdeot[1]
      ratio <- ratio_tdeot
    }
    # So can we stop?
    do_stop <- ratio <= stopping@target_ratio
    # Generate message.
    text1 <- paste(
      "Gstar estimate is",
      round(gstar, 4),
      "with 95% CI (",
      round(ci_gstar[1], 4),
      ",",
      round(ci_gstar[2], 4),
      ") and its ratio =",
      round(ratio_gstar, 4)
    )
    text2 <- paste(
      "TDtargetEndOfTrial estimate is ",
      round(td_target_end_of_trial, 4),
      "with 95% CI (",
      round(ci_tdeot[1], 4),
      ",",
      round(ci_tdeot[2], 4),
      ") and its ratio=",
      round(ratio_tdeot, 4)
    )
    text3 <- paste(
      ifelse(choose_td, "TDtargetEndOfTrial estimate", "Gstar estimate"),
      "is smaller with ratio =",
      round(ratio, 4),
      "which is ",
      ifelse(do_stop, "is less than or equal to", "greater than"),
      "target_ratio =",
      stopping@target_ratio
    )
    text <- c(text1, text2, text3)
    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

# maxSize ----

## generic ----

#' "MAX" Combination of Cohort Size Rules
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function combines cohort size rules by taking the maximum of all sizes.
#'
#' @param ... Objects of class [`CohortSize`].
#'
#' @return The combination as an object of class [`CohortSizeMax`].
#'
#' @seealso [minSize()]
#' @export
#'
setGeneric(
  name = "maxSize",
  def = function(...) {
    # There should be no default method, therefore just forward to next method.
    standardGeneric("maxSize")
  },
  valueClass = "CohortSizeMax"
)

## maxSize-CohortSize ----

#' @describeIn maxSize The method combining cohort size rules by taking maximum.
#'
#' @aliases maxSize-CohortSize
#' @example examples/Rules-method-maxSize.R
#' @export
#'
setMethod(
  f = "maxSize",
  signature = "CohortSize",
  definition = function(...) {
    CohortSizeMax(list(...))
  }
)

# minSize ----

## generic ----

#' "MIN" Combination of Cohort Size Rules
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function combines cohort size rules by taking the minimum of all sizes.
#'
#' @param ... Objects of class [`CohortSize`].
#'
#' @return The combination as an object of class [`CohortSizeMin`].
#'
#' @seealso [maxSize()]
#' @export
#'
setGeneric(
  name = "minSize",
  def = function(...) {
    # There should be no default method, therefore just forward to next method.
    standardGeneric("minSize")
  },
  valueClass = "CohortSizeMin"
)

## minSize-CohortSize ----

#' @describeIn minSize The method combining cohort size rules by taking minimum.
#'
#' @aliases minSize-CohortSize
#' @example examples/Rules-method-minSize.R
#' @export
#'
setMethod(
  f = "minSize",
  signature = "CohortSize",
  definition = function(...) {
    CohortSizeMin(list(...))
  }
)

# size ----

## CohortSizeRange ----

#' @describeIn size Determines the size of the next cohort based on the range
#'   into which the next dose falls into.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeRange
#' @example examples/Rules-method-size-CohortSizeRange.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeRange"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Determine in which interval the next dose is.
    interval <- findInterval(x = dose, vec = object@intervals)
    object@cohort_size[interval]
  }
)

## size-CohortSizeDLT ----

#' @describeIn size Determines the size of the next cohort based on the number
#'   of DLTs so far.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeDLT
#' @example examples/Rules-method-size-CohortSizeDLT.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeDLT"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Determine how many DLTs have occurred so far.
    dlt_happened <- sum(data@y)

    # Determine in which interval this is.
    interval <- findInterval(x = dlt_happened, vec = object@intervals)
    object@cohort_size[interval]
  }
)

## size-CohortSizeMax ----

#' @describeIn size Determines the size of the next cohort based on maximum of
#'   multiple cohort size rules.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeMax
#' @example examples/Rules-method-size-CohortSizeMax.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeMax"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_multi_class(data, c("Data", "DataOrdinal"))

    # Evaluate the individual cohort size rules in the list.
    individual_results <- sapply(
      object@cohort_sizes,
      size,
      dose = dose,
      data = data
    )
    # The overall result.
    max(individual_results)
  }
)

## size-CohortSizeMin ----

#' @describeIn size Determines the size of the next cohort based on minimum of
#'   multiple cohort size rules.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeMin
#' @example examples/Rules-method-size-CohortSizeMin.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeMin"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_multi_class(data, c("Data", "DataOrdinal"))

    # Evaluate the individual cohort size rules in the list.
    individual_results <- sapply(
      object@cohort_sizes,
      size,
      dose = dose,
      data = data
    )
    # The overall result.
    min(individual_results)
  }
)

## size-CohortSizeConst ----

#' @describeIn size Constant cohort size.
#'
#' @param dose the next dose.
#' @param ... not used.
#'
#' @aliases size-CohortSizeConst
#' @example examples/Rules-method-size-CohortSizeConst.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeConst"
  ),
  definition = function(object, dose, ...) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      0L
    } else {
      object@size
    }
  }
)

## size-CohortSizeParts ----

#' @describeIn size Determines the size of the next cohort based on the parts.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeParts
#' @example examples/Rules-method-size-CohortSizeParts.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeParts"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      0L
    } else {
      assert_class(data, "DataParts")
      object@cohort_sizes[data@nextPart]
    }
  }
)

## size-CohortSizeOrdinal ----

#' @describeIn size Determines the size of the next cohort in a ordinal CRM trial.
#'
#' @param dose (`numeric`) the next dose.
#' @param data the data input, an object of class [`DataOrdinal`].
#'
#' @aliases size-CohortSizeOrdinal
#' @example examples/Rules-method-size-CohortSizeOrdinal.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeOrdinal"
  ),
  definition = function(object, dose, data, ...) {
    # Validate
    assert_numeric(dose, len = 1, lower = 0)
    assert_class(data, "DataOrdinal")
    # Execute

    size(
      object@rule,
      dose = dose,
      data = h_convert_ordinal_data(data, object@grade),
      ...
    )
  }
)

# windowLength ----

## generic ----

#' Determine the Safety Window Length of the Next Cohort
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function determines the safety window length of the next cohort.
#'
#' @param safetyWindow (`SafetyWindow`)\cr the rule, an object of class
#'   [`SafetyWindow`].
#' @param size (`integer`)\cr the next cohort size.
#' @param data (`DataDA`)\cr the data input, an object of class [`DataDA`].
#' @param ... additional arguments without method dispatch.
#'
#' @return The `windowLength` as a list of safety window parameters
#'   (`gap`, `follow`, `follow_min`).
#'
#' @export
#'
setGeneric(
  name = "windowLength",
  def = function(safetyWindow, size, ...) {
    # There should be no default method, therefore just forward to next method.
    standardGeneric("windowLength")
  },
  valueClass = "list"
)

## windowLength-SafetyWindowSize ----

#' @describeIn windowLength Determine safety window length based on the cohort
#'   size.
#'
#' @aliases windowLength-SafetyWindowSize
#' @example examples/Rules-method-windowLength-SafetyWindowSize.R
#' @export
#'
setMethod(
  f = "windowLength",
  signature = signature(
    safetyWindow = "SafetyWindowSize",
    size = "ANY"
  ),
  definition = function(safetyWindow, size, data, ...) {
    # Determine in which interval the next size is.
    interval <-
      findInterval(
        x = size,
        vec = safetyWindow@size
      )

    # So the safety window length is.
    patient_gap <- head(
      c(
        0,
        safetyWindow@gap[[interval]],
        rep(tail(safetyWindow@gap[[interval]], 1), 100)
      ),
      size
    )
    patient_follow <- safetyWindow@follow
    patient_follow_min <- safetyWindow@follow_min

    ret <- list(
      patientGap = patient_gap,
      patientFollow = patient_follow,
      patientFollowMin = patient_follow_min
    )

    ret
  }
)

## windowLength-SafetyWindowConst ----

#' @describeIn windowLength Constant safety window length.
#'
#' @aliases windowLength-SafetyWindowConst
#' @example examples/Rules-method-windowLength-SafetyWindowConst.R
#' @export
#'
setMethod(
  f = "windowLength",
  signature = signature(
    safetyWindow = "SafetyWindowConst",
    size = "ANY"
  ),
  definition = function(safetyWindow, size, ...) {
    # First element should be 0.
    patient_gap <- head(
      c(
        0,
        safetyWindow@gap,
        rep(tail(safetyWindow@gap, 1), 100)
      ),
      size
    )
    patient_follow <- safetyWindow@follow
    patient_follow_min <- safetyWindow@follow_min

    ret <- list(
      patientGap = patient_gap,
      patientFollow = patient_follow,
      patientFollowMin = patient_follow_min
    )

    ret
  }
)

# tidy ----

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelative
#' @example examples/Rules-method-tidyIncrementsRelative.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelative"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeDLT ----

#' @rdname tidy
#' @aliases tidy-CohortSizeDLT
#' @example examples/Rules-method-tidyCohortSizeDLT.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeDLT"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(cohort_size = x@cohort_size) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeMin ----

#' @rdname tidy
#' @aliases tidy-CohortSizeMin
#' @example examples/Rules-method-tidyCohortSizeMin.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeMin"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-CohortSizeMax ----

#' @rdname tidy
#' @aliases tidy-CohortSizeMax
#' @example examples/Rules-method-tidyCohortSizeMax.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeMax"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-CohortSizeRange ----

#' @rdname tidy
#' @aliases tidy-CohortSizeRange
#' @example examples/Rules-method-tidyCohortSizeRange.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeRange"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(cohort_size = x@cohort_size) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeParts ----

#' @rdname tidy
#' @aliases tidy-CohortSizeParts
#' @example examples/Rules-method-tidyCohortSizeParts.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeParts"),
  definition = function(x, ...) {
    tibble::tibble(
      part = seq_along(x@cohort_sizes),
      cohort_size = x@cohort_sizes
    ) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsMin ----

#' @rdname tidy
#' @aliases tidy-IncrementsMin
#' @example examples/Rules-method-tidyIncrementsMin.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsMin"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelative
#' @example examples/Rules-method-tidyIncrementsRelative.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelative"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(dplyr::row_number() > 1) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsRelativeDLT ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelativeDLT
#' @example examples/Rules-method-tidyIncrementsRelativeDLT.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelativeDLT"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(dplyr::row_number() > 1) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelativeParts
#' @example examples/Rules-method-tidyIncrementsRelativeParts.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelativeParts"),
  definition = function(x, ...) {
    slot_names <- slotNames(x)
    rv <- list()
    for (nm in slot_names) {
      if (!is.function(slot(x, nm))) {
        rv[[nm]] <- h_tidy_slot(x, nm, ...)
      }
    }
    # Column bind of all list elements have the same number of rows.
    if (length(rv) > 1 & length(unique(sapply(rv, nrow))) == 1) {
      rv <- rv %>% dplyr::bind_cols()
    }
    rv <- rv %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

## tidy-NextBestNCRM ----

#' @rdname tidy
#' @aliases tidy-NextBestNCRM
#' @example examples/Rules-method-tidyNextBestNCRM.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "NextBestNCRM"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$target, range_min = 0, range_max = 1) %>%
      add_column(max_prob = c(NA, NA, x@max_overdose_prob)) %>%
      add_column(Range = c("Underdose", "Target", "Overdose"), .before = 1) %>%
      h_tidy_class(x)
  }
)

## tidy-NextBestNCRMLoss ----

#' @rdname tidy
#' @aliases tidy-NextBestNCRMLoss
#' @example examples/Rules-method-tidyNextBestNCRMLoss.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "NextBestNCRMLoss"),
  definition = function(x, ...) {
    tibble(
      Range = "Underdose",
      Lower = 0,
      Upper = x@target[1]
    ) %>%
      dplyr::bind_rows(
        lapply(
          c("target", "overdose", "unacceptable"),
          function(nm, obj) {
            tibble::tibble(
              Range = stringr::str_to_sentence(nm),
              Lower = slot(obj, nm)[1],
              Upper = slot(obj, nm)[2]
            )
          },
          obj = x
        ) %>%
          dplyr::bind_rows()
      ) %>%
      add_column(LossCoefficient = x@losses) %>%
      add_column(MaxOverdoseProb = x@max_overdose_prob) %>%
      h_tidy_class(x)
  }
)

# Validate-class ----

#' `Validate`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The [`Validate`] class is a Reference Class
#' to help programming validation for new S4 classes.
#'
#' @details Starting from an empty `msg` vector, with each check
#'   that is returning `FALSE` the vector gets a new element - the string
#'   explaining the failure of the validation.
#'
#' @name Validate
#' @field msg (`character`)\cr the cumulative messages.
#'
Validate <- setRefClass(
  Class = "Validate",
  fields = list(msg = "character"),
  methods = list(
    check = function(test, string = "") {
      "Check whether the \\code{test} is \\code{TRUE}; if so, return \\code{NULL}.
      Otherwise, add the \\code{string} message into the cumulative messages vector \\code{msg}."
      assert_flag(test)
      assert_string(string)
      if (test) {
        NULL
      } else {
        msg <<- c(msg, string)
      }
    },
    result = function() {
      "Return either cumulative messages vector \\code{msg}
      (which contains the error messages from all the checks),
      or \\code{NULL}, if \\code{msg} is empty (i.e. all the checks were successful)."
      if (length(msg) > 0) {
        msg
      } else {
        TRUE
      }
    }
  )
)

# positive_number-class ----

#' `positive_number`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' The [`positive_number`] class is a class to store not `NULL`, non `NA`,
#' finite and strictly positive numerical value. It is mainly used to store
#' reference dose value in model classes.
#'
#' @name positive_number
#'
positive_number <- setClass(
  Class = "positive_number",
  contains = "numeric",
  validity = function(object) {
    v <- Validate()
    v$check(
      test_number(object, finite = TRUE) && object > 0,
      "Object's value must be strictly positive"
    )
    v$result()
  }
)

# match_within_tolerance ----

#' Helper Function for Value Matching with Tolerance
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a modified version of [match()] that supports tolerance.
#'
#' @param x (`numeric`)\cr the values to be matched.
#' @param table (`numeric`)\cr the values to be matched against.
#' @param tolerance (`number`)\cr the numerical tolerance for comparison.
#'
#' @return An integer vector of the same length as `x` giving the position
#'   in `table` of the first match, or an empty integer vector if `table` is empty.
#'   `NA` is returned for values in `x` that have no match.
#'
#' @export
#'
#' @examples
#' match_within_tolerance(c(0.1, 0.2, 0.3), c(0.10000001, 0.5, 0.3))
#' match_within_tolerance(1.5, numeric(0))
match_within_tolerance <- function(x, table, tolerance = 1e-10) {
  assert_numeric(x)
  assert_numeric(table)
  assert_number(tolerance, lower = .Machine$double.xmin, finite = TRUE)

  if (length(table) == 0) {
    integer()
  } else {
    as.integer(vapply(
      x,
      function(val) {
        matches <- vapply(
          table,
          function(tbl_val) {
            isTRUE(all.equal(
              val,
              tbl_val,
              tolerance = tolerance,
              check.names = FALSE,
              check.attributes = FALSE
            ))
          },
          logical(1)
        )
        which(matches)[1L]
      },
      integer(1)
    ))
  }
}

# logit ----

#' Shorthand for Logit Function
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Computes the logit transformation.
#'
#' @param x (`numeric`)\cr the function argument.
#'
#' @return The logit of `x`, computed as `log(x / (1 - x))`.
#'
#' @export
#'
#' @examples
#' logit(0.5)
#' logit(c(0.1, 0.5, 0.9))
logit <- function(x) {
  qlogis(x)
}

# probit ----

#' Shorthand for Probit Function
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Computes the probit (inverse cumulative distribution function of standard normal) transformation.
#'
#' @param x (`numeric`)\cr the function argument.
#'
#' @return The probit of `x`, the quantile function of the standard normal distribution.
#'
#' @export
#'
#' @examples
#' probit(0.5)
#' probit(c(0.025, 0.5, 0.975))
probit <- function(x) {
  qnorm(x)
}

# crmPackExample ----

#' Open the Example PDF for crmPack
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Calling this helper function opens the `example.pdf` document,
#' residing in the `doc` subfolder of the package installation directory.
#'
#' @return Called for side effects.
#'
#' @export
crmPackExample <- function() {
  crm_path <- system.file(package = "crmPack")
  printVignette(list(PDF = "example.pdf", Dir = crm_path))
}

# crmPackHelp ----

#' Open the Browser with Help Pages for crmPack
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This convenience function opens your browser with the help pages for crmPack.
#'
#' @return Called for side effects.
#'
#' @export
#' @importFrom utils help
crmPackHelp <- function() {
  utils::help(package = "crmPack", help_type = "html")
}

# plot.gtable ----

#' Plot `gtable` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is needed because `crmPack` uses [gridExtra::arrangeGrob()] to combine
#' `ggplot2` plots, and the resulting `gtable` object is not plotted otherwise
#' when implicitly printing it in the console.
#'
#' @method plot gtable
#' @param x (`gtable`)\cr object to plot.
#' @param ... additional parameters for [grid::grid.draw()].
#'
#' @export
plot.gtable <- function(x, ...) {
  grid::grid.draw(x, ...)
}

# print.gtable ----

#' @method print gtable
#' @param x (`gtable`)\cr object to print.
#' @param ... additional parameters passed to [plot.gtable()].
#' @rdname plot.gtable
#' @return Called for side effects.
#' @export
print.gtable <- function(x, ...) {
  plot(x, ...)
}

# printVignette ----

#' Print Vignette
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Taken from utils package (`print.vignette`).
#'
#' @param x (`list`)\cr vignette information.
#' @param ... not used.
#'
#' @return `x` invisibly.
#'
#' @importFrom tools file_ext
#' @importFrom utils browseURL
#' @keywords internal
printVignette <- function(x, ...) {
  if (nzchar(out <- x$PDF)) {
    ext <- tools::file_ext(out)
    out <- file.path(x$Dir, "doc", out)
    if (tolower(ext) == "pdf") {
      pdf_viewer <- getOption("pdfviewer")
      if (identical(pdf_viewer, "false")) {} else if (
        .Platform$OS.type == "windows" &&
          identical(pdf_viewer, file.path(R.home("bin"), "open.exe"))
      ) {
        shell.exec(out)
      } else {
        system2(pdf_viewer, shQuote(out), wait = FALSE)
      }
    } else {
      browseURL(out)
    }
  } else {
    warning(
      gettextf("vignette %s has no PDF/HTML", sQuote(x$Topic)),
      call. = FALSE,
      domain = NA
    )
  }
  invisible(x)
}

# dinvGamma ----

#' Compute the Density of Inverse Gamma Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x (`numeric`)\cr vector of quantiles.
#' @param a (`number`)\cr the shape parameter of the inverse gamma distribution.
#' @param b (`number`)\cr the scale parameter of the inverse gamma distribution.
#' @param log (`flag`)\cr if `TRUE`, probabilities `p` are given as `log(p)`.
#' @param normalize (`flag`)\cr if `TRUE`, the output will be normalized.
#'
#' @return The density value(s).
#'
#' @keywords internal
dinvGamma <- function(x, a, b, log = FALSE, normalize = TRUE) {
  ret <- -(a + 1) * log(x) - b / x
  if (normalize) {
    ret <- ret + a * log(b) - lgamma(a)
  }
  if (log) {
    ret
  } else {
    exp(ret)
  }
}

# pinvGamma ----

#' Compute the Distribution Function of Inverse Gamma Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param q (`numeric`)\cr vector of quantiles.
#' @param a (`number`)\cr the shape parameter of the inverse gamma distribution.
#' @param b (`number`)\cr the scale parameter of the inverse gamma distribution.
#' @param lower.tail (`flag`)\cr if `TRUE` (default), probabilities are `P(X <= x)`,
#'   otherwise, `P(X > x)`.
#' @param log.p (`flag`)\cr if `TRUE`, probabilities/densities `p` are returned as `log(p)`.
#'
#' @return The distribution function value(s).
#'
#' @keywords internal
# nolint start
pinvGamma <- function(q, a, b, lower.tail = TRUE, log.p = FALSE) {
  # nolint end
  pgamma(
    q = 1 / q,
    shape = a,
    rate = b,
    lower.tail = !lower.tail,
    log.p = log.p
  )
}

# qinvGamma ----

#' Compute the Quantile Function of Inverse Gamma Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param p (`numeric`)\cr vector of probabilities.
#' @param a (`number`)\cr the shape parameter of the inverse gamma distribution.
#' @param b (`number`)\cr the scale parameter of the inverse gamma distribution.
#' @param lower.tail (`flag`)\cr if `TRUE` (default), probabilities are `P(X <= x)`,
#'   otherwise, `P(X > x)`.
#' @param log.p (`flag`)\cr if `TRUE`, probabilities/densities `p` are given as `log(p)`.
#'
#' @return The quantile value(s).
#'
#' @keywords internal
# nolint start
qinvGamma <- function(p, a, b, lower.tail = TRUE, log.p = FALSE) {
  # nolint end
  1 /
    qgamma(
      p = p,
      shape = a,
      rate = b,
      lower.tail = !lower.tail,
      log.p = log.p
    )
}

# rinvGamma ----

#' Random Generation for the Inverse Gamma Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param n (`count`)\cr the number of observations.
#' @param a (`number`)\cr the shape parameter of the inverse gamma distribution.
#' @param b (`number`)\cr the scale parameter of the inverse gamma distribution.
#'
#' @return A vector of random values from the inverse gamma distribution.
#'
#' @keywords internal
rinvGamma <- function(n, a, b) {
  1 / rgamma(n, shape = a, rate = b)
}

#' Combining S4 Class Validation Results
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that combines two outputs from calls to `result()`
#'   function which is placed in a slot of [Validate()] reference class.
#'
#' @param v1 (`logical` or `character`)\cr an output from `result()` function from
#'   [Validate()] reference class, to be combined with `v2`.
#' @param v2 (`logical` or `character`)\cr an output from `result()` function from
#'   [Validate()] reference class, to be combined with `v1`.
#'
#' @export
#' @examples
#' h_validate_combine_results(TRUE, "some_message")
h_validate_combine_results <- function(v1, v2) {
  assert_true(
    test_true(v1) || test_character(v1, any.missing = FALSE, min.len = 1L)
  )
  assert_true(
    test_true(v2) || test_character(v2, any.missing = FALSE, min.len = 1L)
  )

  isTRUEv2 <- isTRUE(v2)
  if (isTRUE(v1)) {
    if (isTRUEv2) {
      TRUE
    } else {
      v2
    }
  } else {
    if (isTRUEv2) {
      v1
    } else {
      c(v1, v2)
    }
  }
}

#' Comparison with Numerical Tolerance and Without Name Comparison
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function ensures a default tolerance level equal to `1e-10`,
#' and ignores names and other attributes.
#' In contrast to [all.equal()], it always returns a logical type object.
#'
#' @param target (`numeric`)\cr target values.
#' @param current (`numeric`)\cr current values.
#' @param tolerance (`number`) relative differences smaller than this are not
#'   reported.
#' @return `TRUE` when `target` and `current` do not differ
#'   up to desired tolerance and without looking at names or other attributes,
#'   `FALSE` otherwise.
#'
#' @export
#'
h_all_equivalent <- function(target, current, tolerance = 1e-10) {
  assert_numeric(target)
  assert_numeric(current)
  assert_number(tolerance)

  tmp <- all.equal(
    target = target,
    current = current,
    tolerance = tolerance,
    check.names = FALSE,
    check.attributes = FALSE
  )
  isTRUE(tmp)
}

#' Preparing Data for Plotting
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function prepares a `data.frame` object based on `Data` class
#' object. The resulting data frame is used by the plot function for `Data`
#' class objects.
#'
#' @param data (`Data`)\cr object from which data is extracted and converted
#'   into a data frame.
#' @param blind (`flag`)\cr should data be blinded?
#'   If `TRUE`, then for each cohort, all DLTs are assigned to the first
#'   subjects in the cohort. In addition, the placebo (if any) is set to the
#'   active dose level for that cohort.
#' @param ... further arguments passed to `data.frame` constructor.
#'   It can be e.g. an extra `column_name = value` pair based on a slot
#'   from `x` (which in this case might be a subclass of `Data`)
#'   which does not appear in `Data`.
#' @return A [`data.frame`] object with values to plot.
#'
h_plot_data_df <- function(data, blind = FALSE, ...) {
  df <- data.frame(
    patient = seq_along(data@x),
    ID = paste(" ", data@ID),
    cohort = data@cohort,
    dose = data@x,
    toxicity = ifelse(data@y == 1, "Yes", "No"),
    ...
  )

  if (blind) {
    # This is to blind the data.
    # For each cohort, all DLTs are assigned to the first subjects in the cohort.
    # In addition, the placebo (if any) is set to the active dose level for that
    # cohort.
    # Notice: dapply reorders records of df according to the lexicographic order
    # of cohort.
    df <- dapply(df, f = ~cohort, FUN = function(coh) {
      coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
      coh$dose <- max(coh$dose)
      coh
    })
  } else if (data@placebo) {
    # Placebo will be plotted at y = 0 level.
    df$dose[df$dose == data@doseGrid[1]] <- 0
  }

  df
}

#' Preparing Cohort Lines for Data Plot
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function prepares a `ggplot` geom with reference lines
#' separating different cohorts on the plot of `Data` class object.
#' Lines are either vertical or horizontal of green color and longdash type.
#'
#' @details The geom object is returned if and only if `placebo` is equal to
#'   `TRUE` and there are more than one unique values in `cohort`. Otherwise,
#'   this function returns `NULL` object.
#'
#' @param cohort (`integer`)\cr the cohort indices.
#' @param placebo (`flag`)\cr is placebo included in the doses?
#'   If it so, this function returns `NULL` object as in this case all doses
#'   in a given cohort are equal and there is no need to separate them.
#' @param vertical (`flag`)\cr should the line be vertical? Otherwise it is
#'   horizontal.
#'
h_plot_data_cohort_lines <- function(cohort, placebo, vertical = TRUE) {
  assert_integer(cohort)
  assert_flag(placebo)
  assert_flag(vertical)

  # If feasible, add vertical or horizontal green lines separating sub-sequent
  # cohorts.
  if (placebo && length(unique(cohort)) > 1) {
    intercept <- head(cumsum(table(cohort)), n = -1) + 0.5
    if (vertical) {
      geom_vline(
        xintercept = intercept,
        colour = "green",
        linetype = "longdash"
      ) # nolintr
    } else {
      geom_hline(
        yintercept = intercept,
        colour = "green",
        linetype = "longdash"
      ) # nolintr
    }
  } else {
    NULL
  }
}

#' Checking Formals of a Function
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function checks whether a given function `fun` has required or
#' allowed arguments. The argument check is based only on the names of the
#' arguments. No any further logic is verified here.
#'
#' @param fun (`function`)\cr a function name whose argument names will be
#'   checked.
#' @param mandatory (`character` or `NULL`)\cr the names of the arguments which
#'   must be present in `fun`. If `mandatory` is specified as `NULL` (default)
#'   this requirement is ignored.
#' @param allowed (`character` or `NULL`)\cr the names of the arguments which
#'   are allowed in `fun`. Names that do not belong to `allowed` are simply not
#'   allowed. The `allowed` parameter is independent from the `mandatory`, in a
#'   sense that if `mandatory` is specified as a `character` vector, it does not
#'   have to be repeated in `allowed`. If `allowed` is specified as `NULL`
#'   (default), then it means that there must be no any arguments in `fun`
#'   (except these ones which are specified in `mandatory`).
#'
#' @export
#'
h_check_fun_formals <- function(fun, mandatory = NULL, allowed = NULL) {
  assert_function(fun)
  assert_character(mandatory, null.ok = TRUE)
  assert_character(allowed, null.ok = TRUE)

  arg_names <- names(formals(fun))
  mandatory_check <- all(mandatory %in% arg_names)
  allowed_check <- all(arg_names %in% c(mandatory, allowed))

  mandatory_check && allowed_check
}

#' Getting the Slots from a S4 Object
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function extracts requested slots from the S4 class object.
#' It is a simple wrapper of [methods::slot()] function.
#'
#' @param object (`S4`)\cr an object from a formally defined S4 class.
#' @param names (`character`)\cr a vector with names of slots to be fetched.
#'   This function assumes that for every element in `names`, there exists a
#'   slot of the same name in the `object`.
#' @param simplify (`flag`)\cr should an output be simplified? This has an
#'   effect if and only if a single slot is about to be extracted, i.e.
#'   `names` is just a single string.
#'
#' @return `list` with the slots extracted from `object` according to `names`,
#'   or single slot if simplification is required and possible.
#'
#' @export
#'
h_slots <- function(object, names, simplify = FALSE) {
  assert_true(isS4(object))
  assert_character(names, any.missing = FALSE, null.ok = TRUE)
  assert_true(all(names %in% slotNames(object)))

  if (is.null(names) || length(names) == 0L) {
    return(list())
  }

  slots_list <- sapply(
    names,
    function(n) slot(object, n),
    simplify = FALSE,
    USE.NAMES = TRUE
  )

  if (simplify && length(names) == 1) {
    slots_list[[1]]
  } else {
    slots_list
  }
}

#' Conditional Formatting Using C-style Formats
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function conditionally formats a number with [formatC()]
#' function using `"E"` format and specific number of digits as given by the
#' user. A number is formatted if and only if its absolute value is less than
#' `0.001` or greater than `10000`. Otherwise, the number is not formatted.
#' Additionally, custom prefix or suffix can be appended to character string
#' with formatted number, so that the changes are marked.
#'
#' @note This function was primarily designed as a helper for
#'   [h_jags_write_model()] function.
#'
#' @param x (`number`)\cr a number to be formatted.
#' @param digits (`function`)\cr the desired number of significant digits.
#' @param prefix (`string`)\cr a prefix to be added in front of the formatted
#'   number.
#' @param suffix (`string`)\cr a suffix to be appended after the formatted
#'   number.
#'
#' @return Either formatted `x` as `string` or unchanged `x` if the
#'   formatting condition is not met.
#'
#' @export
#' @examples
#' h_format_number(50000)
#' h_format_number(50000, prefix = "P", suffix = "S")
h_format_number <- function(x, digits = 5, prefix = "", suffix = "") {
  assert_number(x)
  assert_int(digits)
  assert_string(prefix)
  assert_string(suffix)

  if ((abs(x) < 1e-3) || (abs(x) > 1e+4)) {
    paste0(prefix, formatC(x, digits = digits, format = "E"), suffix)
  } else {
    x
  }
}

#' Recursively Apply a Function to a List
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function recursively iterates through a "list-like" object and it
#' checks whether an element is of a given class. If it so, then it replaces
#' that element by the result of an execution of a given function. Otherwise,
#' and if the element is of length greater than 1 (i.e. not a scalar), it
#' replaces that element by the result of `h_rapply()`, recursively called for
#' that element. In the remaining case, that is, the element is not of a given
#' class and is a scalar, then that element remains unchanged.
#'
#' @note This helper function is conceptually similar the same as [rapply()]
#'   function. However, it differs from [rapply()] in two major ways. First, the
#'   `h_rapply()` is not limited to objects of type `list` or `expression` only.
#'   It can be any "list-like" object of any type for which subsetting operator
#'   [`[[`][Extract] is defined. This can be, for example, an object of type
#'   `language`, often obtained from the [body()] function. The second
#'   difference is that the flexibility of [rapply()] on how the result is
#'   structured is not available with `h_rapply()` for the user. That is, with
#'   `h_rapply()` each element of `x`, which has a class included in `classes`,
#'   is replaced by the result of applying `fun` to the element. This behavior
#'   corresponds to [rapply()] when invoked with fixed `how = replace`.
#'   This function was primarily designed as a helper for [h_jags_write_model()]
#'   function.
#'
#' @param x (`any`)\cr "list-like" object for which subsetting operator
#'   [`[[`][Extract] is defined.
#' @param fun (`function`)\cr a function of one "principal" argument, passing
#'   further arguments via `...`.
#' @param classes (`character`)\cr class names.
#' @param ... further arguments passed to function `fun`.
#'
#' @return "list-like" object of similar structure as `x`.
#'
#' @export
#' @example examples/helpers-rapply.R
#'
h_rapply <- function(x, fun, classes, ...) {
  assert_function(fun)
  assert_character(classes, min.len = 1L)
  # To assert that `x` is subsettable.
  # If it works, fine, we don't see the result, otherwise it gives the error.
  force(x[[1]])

  for (i in seq_along(x)) {
    if (class(x[[i]]) %in% classes) {
      x[[i]] <- do.call(fun, c(list(x[[i]]), ...))
    } else if (length(x[[i]]) > 1L) {
      x[[i]] <- h_rapply(x[[i]], fun, classes, ...)
    }
  }
  x
}

#' Getting `NULL` for `NA`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that replaces `NA` object by `NULL` object.
#'
#' @param x (`any`)\cr atomic object of length `1`. For the definition of
#'   "atomic", see [is.atomic()].
#'
#' @return `NULL` if `x` is `NA`, otherwise, `x`.
#'
#' @export
#' @examples
#' h_null_if_na(NA)
h_null_if_na <- function(x) {
  assert_atomic(x, len = 1L)

  if (is.na(x)) {
    NULL
  } else {
    x
  }
}

#' Getting the default value for an empty object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that sets a default value for an empty or missing object,
#' that is an object for which [length()] function returns `0L` or it has length 1
#' and [is.na()] returns `TRUE`.
#'
#' @param x (`any`) \cr an object to handle. It can be any object for which
#'   [length()] function is defined.
#' @param default (`any`) \cr a default value for `x` object.
#'
#' @export
#' @examples
#' h_default_if_empty(character(0), default = "default label")
#' h_default_if_empty("custom label", default = "default label")
#' h_default_if_empty(NA, default = "default label")
h_default_if_empty <- function(x, default) {
  if (length(x) == 0L || (length(x) == 1L && is.na(x))) {
    default
  } else {
    x
  }
}
#' Testing Matrix for Positive Definiteness
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function checks whether a given numerical matrix `x` is a
#' positive-definite square matrix of a given size, without any missing
#' values. This function is used to test if a given matrix is a covariance
#' matrix, since every symmetric positive semi-definite matrix is a covariance
#' matrix.
#'
#' @details The positive definiteness test implemented in this function
#'   is based on the following characterization valid for real matrices:
#'   `A symmetric matrix is positive-definite if and only if all of its
#'   eigenvalues are positive.` In this function an eigenvalue is considered
#'   as positive if and only if it is greater than the `tol`.
#'
#' @param x (`matrix`)\cr a matrix to be checked.
#' @param size (`integer`)\cr a size of the square matrix `x` to be checked
#'   against for.
#' @param tol (`number`)\cr a given tolerance number used to check whether
#'   an eigenvalue is positive or not. An eigenvalue is considered
#'   as positive if and only if it is greater than the `tol`.
#'
#' @return `TRUE` if a given matrix is a positive-definite, `FALSE` otherwise.
#'
#' @export
#'
h_is_positive_definite <- function(x, size = 2, tol = 1e-06) {
  assert_number(tol)

  is_matrix <- test_matrix(
    x,
    mode = "numeric",
    nrows = size,
    ncols = size,
    any.missing = FALSE
  )

  if (is_matrix) {
    is_symmetric <- all.equal(x, t(x), tolerance = tol)
    if (isTRUE(is_symmetric)) {
      # Use Cholesky decomposition which is more robust than eigenvalue computation
      chol_result <- try(chol(x), silent = TRUE)
      !inherits(chol_result, "try-error")
    } else {
      FALSE
    }
  } else {
    FALSE
  }
}

#' Check that an argument is a named vector of type numeric
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that tests whether an object is a named numerical
#' vector.
#'
#' @note This function is based on [`checkmate::test_numeric()`] and
#'   [`checkmate::test_names()`] functions.
#'
#' @param x (`any`)\cr object to check.
#' @inheritParams checkmate::test_names
#' @inheritParams checkmate::test_numeric
#' @param ... further parameters passed to [`checkmate::test_numeric()`].
#'
#' @return `TRUE` if `x` is a named vector of type numeric, otherwise `FALSE`.
#'
#' @export
#' @examples
#' h_test_named_numeric(1:2, permutation.of = c("a", "b"))
#' h_test_named_numeric(c(a = 1, b = 2), permutation.of = c("a", "b"))
#' h_test_named_numeric(c(a = 1, b = 2), permutation.of = c("b", "a"))
h_test_named_numeric <- function(
  x,
  subset.of = NULL, # nolintr
  must.include = NULL, # nolintr
  permutation.of = NULL, # nolintr
  identical.to = NULL, # nolintr
  disjunct.from = NULL, # nolintr
  lower = 0 + .Machine$double.xmin,
  finite = TRUE,
  any.missing = FALSE, # nolintr
  len = 2,
  ...
) {
  is_valid_num <- test_numeric(
    x,
    lower = lower,
    finite = finite,
    any.missing = any.missing,
    len = len,
    ...,
    names = "named"
  )
  are_names_valid <- test_names(
    names(x),
    subset.of = subset.of,
    must.include = must.include,
    permutation.of = permutation.of,
    identical.to = identical.to,
    disjunct.from = disjunct.from,
  )
  is_valid_num && are_names_valid
}

#' Check which elements are in a given range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that tests whether elements of a given vector or
#' matrix are within specified interval.
#'
#' @param x (`numeric`)\cr vector or matrix with elements to test.
#' @param range (`numeric`)\cr an interval, i.e. sorted two-elements vector.
#' @param bounds_closed (`logical`)\cr should bounds in the `range` be treated
#'   as closed? This can be a scalar or vector of length two. If it is a scalar,
#'   then its value applies to lower bound `range[1]` and upper bound
#'   `range[2]`. If this is a vector with two flags, the first flag corresponds
#'   to the lower bound only, and the second to the upper bound only.
#'
#' @return A logical vector or matrix of length equal to the length of `x`, that
#'   for every element of `x`, indicates whether a given element of `x` is in
#'   the `range`.
#'
#' @export
#' @examples
#' x <- 1:4
#' h_in_range(x, range = c(1, 3))
#' h_in_range(x, range = c(1, 3), bounds_closed = FALSE)
#' h_in_range(x, range = c(1, 3), bounds_closed = c(FALSE, TRUE))
#' mat <- matrix(c(2, 5, 3, 10, 4, 9, 1, 8, 7), nrow = 3)
#' h_in_range(mat, range = c(1, 5))
h_in_range <- function(x, range = c(0, 1), bounds_closed = TRUE) {
  assert_numeric(x)
  assert_numeric(range, any.missing = FALSE, len = 2, sorted = TRUE)
  assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)

  above_lwr <- if (bounds_closed[1]) {
    x >= range[1]
  } else {
    x > range[1]
  }

  below_upr <- if (tail(bounds_closed, 1)) {
    x <= range[2]
  } else {
    x < range[2]
  }

  above_lwr & below_upr
}

#' Find Interval Numbers or Indices and Return Custom Number For 0.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple wrapper of [`findInterval()`] function that invokes
#' [`findInterval()`], takes its output and replaces all the
#' elements with \eqn{0} value to a custom number as specified in `replacement`
#' argument.
#'
#' @inheritDotParams base::findInterval
#' @param replacement (`number`)\cr a custom number to be used as a replacement
#'   for \eqn{0}. Default to `-Inf`.
#'
#' @export
#' @examples
#' h_find_interval(1, c(2, 4, 6))
#' h_find_interval(3, c(2, 4, 6))
#' h_find_interval(1, c(2, 4, 6), replacement = -1)
h_find_interval <- function(..., replacement = -Inf) {
  assert_number(replacement)

  x <- findInterval(...)
  ifelse(x == 0, yes = replacement, no = x)
}


#' Group Together Mono and Combo Data
#'
#' This is only used in the simulation method for `DesignGrouped` to combine
#' the separately generated data sets from mono and combo arms and to fit the
#' combined logistic regression model.
#' Hence the ID and cohort information is not relevant and will be
#' arbitrarily assigned to avoid problems with the [`DataGrouped`] validation.
#'
#' @param mono_data (`Data`)\cr mono data.
#' @param combo_data (`Data`)\cr combo data.
#'
#' @return A [`DataGrouped`] object containing both `mono_data` and `combo_data`,
#'   but with arbitrary ID and cohort slots.
#'
#' @keywords internal
h_group_data <- function(mono_data, combo_data) {
  assert_class(mono_data, "Data")
  assert_class(combo_data, "Data")

  df <- data.frame(
    x = c(mono_data@x, combo_data@x),
    y = c(mono_data@y, combo_data@y),
    group = rep(
      c("mono", "combo"),
      c(length(mono_data@x), length(combo_data@x))
    )
  )
  df <- df[order(df$x), ]

  DataGrouped(
    x = df$x,
    y = df$y,
    ID = seq_along(df$x),
    cohort = as.integer(factor(df$x)),
    doseGrid = sort(unique(c(mono_data@doseGrid, combo_data@doseGrid))),
    group = df$group
  )
}

#' @include helpers.R
#' @include helpers_covr.R
#' @include logger.R
#' @include Samples-class.R
NULL

# mcmc ----

#' Obtaining Posterior Samples for all Model Parameters
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is the function that actually runs the `JAGS` MCMC machinery to produce
#' posterior samples from all model parameters and required derived values.
#' It is a generic function, so that customized versions may be conveniently
#' defined for specific subclasses of [`GeneralData`], [`GeneralModel`], and
#' [`McmcOptions`] input.
#'
#' @note The type of Random Number Generator (RNG) and its initial seed used by
#'   `JAGS` are taken from the `options` argument. If no initial values are
#'   supplied (i.e RNG kind or seed slot in `options` has `NA`), then they will
#'   be generated automatically by `JAGS`.
#'
#' @param data (`GeneralData`)\cr an input data.
#' @param model (`GeneralModel`)\cr an input model.
#' @param options (`McmcOptions`)\cr MCMC options.
#' @param ... not used.
#'
#' @return The posterior samples, an object of class [`Samples`].
#' @export
#'
setGeneric(
  name = "mcmc",
  def = function(data, model, options, ...) {
    standardGeneric("mcmc")
  },
  valueClass = "Samples"
)

# mcmc-GeneralData ----

#' @describeIn mcmc Standard method which uses JAGS.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData
#' @example examples/mcmc.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "GeneralModel",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    assert_flag(from_prior)

    model_fun <- if (from_prior) {
      model@priormodel
    } else {
      h_jags_join_models(model@datamodel, model@priormodel)
    }

    model_file <- h_jags_write_model(model_fun)
    model_inits <- h_jags_get_model_inits(model, data)
    model_data <- h_jags_get_data(model, data, from_prior)

    jags_model <- rjags::jags.model(
      file = model_file,
      data = model_data,
      inits = c(
        model_inits,
        .RNG.name = h_null_if_na(options@rng_kind),
        .RNG.seed = h_null_if_na(options@rng_seed)
      ),
      quiet = !is_logging_enabled(),
      n.adapt = 0 # No adaptation. Important for reproducibility.
    )
    update(jags_model, n.iter = options@burnin, progress.bar = "none")

    # This is necessary as some outputs are written directly from the JAGS
    # compiled code to the outstream.
    log_trace("Running rjags::jags.samples")
    if (is_logging_enabled()) {
      jags_samples <- rjags::jags.samples(
        model = jags_model,
        variable.names = model@sample,
        n.iter = (options@iterations - options@burnin),
        thin = options@step
      )
    } else {
      invisible(
        capture.output(
          jags_samples <- rjags::jags.samples(
            model = jags_model,
            variable.names = model@sample,
            n.iter = (options@iterations - options@burnin),
            thin = options@step,
            progress.bar = "none"
          )
        )
      )
    }
    log_trace("JAGS samples: ", jags_samples, capture = TRUE)
    samples <- lapply(jags_samples, h_jags_extract_samples)

    Samples(data = samples, options = options)
  }
)

# mcmc-GeneralData-DualEndpointRW ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointRW`] model, it is required that there are at least two (in
#'   case of random walk prior of the first order on the biomarker level) or
#'   three doses in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointRW
#' @example examples/mcmc-DualEndpointRW.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointRW",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    if (model@rw1) {
      assert_true(data@nGrid >= 2)
    } else {
      assert_true(data@nGrid >= 3)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-DualEndpointBeta ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointBeta`] model, it is required that the value of `ref_dose_beta`
#'   slot is greater than the maximum dose in a grid. This requirement comes from
#'   definition of the beta function that is used to model dose-biomarker
#'   relationship in [`DualEndpointBeta`] model. The other requirement is that
#'   there must be at least one dose in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointBeta
#' @example examples/mcmc-DualEndpointBeta.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointBeta",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    assert_true(data@nGrid >= 1)
    assert_true(model@ref_dose_beta > data@doseGrid[data@nGrid])

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-DualEndpointEmax ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointEmax`] model, it is required that there is at least one dose
#'   in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointEmax
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointEmax",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    assert_true(data@nGrid >= 1)

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-OneParLogNormalPrior ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`OneParLogNormalPrior`] model, it is required that the length of
#'   skeleton prior probabilities vector should be equal to the length of the
#'   number of doses.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-OneParLogNormalPrior
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "OneParLogNormalPrior",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    if (!from_prior) {
      assert_true(length(model@skel_probs) == data@nGrid)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-OneParExpPrior ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`OneParExpPrior`] model, it is required that the length of
#'   skeleton prior probabilities vector should be equal to the length of the
#'   number of doses.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-OneParExpPrior
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "OneParExpPrior",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    if (!from_prior) {
      assert_true(length(model@skel_probs) == data@nGrid)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-DataMixture ----

#' @describeIn mcmc Method for [`DataMixture`] with different `from_prior` default.
#'   Samples from the prior only when both the number of observations and the
#'   number of shared observations are zero.
#'
#' @aliases mcmc-DataMixture
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataMixture",
    model = "GeneralModel",
    options = "McmcOptions"
  ),
  def = function(
    data,
    model,
    options,
    from_prior = data@nObs == 0L & data@nObsshare == 0L,
    ...
  ) {
    callNextMethod(data, model, options, from_prior = from_prior, ...)
  }
)

# myBayesLogit ----

#' MCMC Sampling for Bayesian Logistic Regression Model
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Replacement for `BayesLogit::logit`. Performs MCMC sampling for Bayesian
#' logistic regression using JAGS.
#'
#' @param y (`integer`)\cr 0/1 vector of responses.
#' @param X (`matrix`)\cr design matrix.
#' @param m0 (`numeric`)\cr prior mean vector.
#' @param P0 (`matrix`)\cr precision matrix.
#' @param options (`McmcOptions`)\cr MCMC options.
#'
#' @return The matrix of samples (samples x parameters).
#'
#' @keywords internal
myBayesLogit <- function(y, X, m0, P0, options) {
  # Assertions.
  p <- length(m0)
  n_obs <- length(y)
  assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE, len = n_obs)
  assert_numeric(m0, any.missing = FALSE, len = p)
  assert_matrix(P0, mode = "numeric", any.missing = FALSE, nrows = p, ncols = p)
  assert_matrix(
    X,
    mode = "numeric",
    any.missing = FALSE,
    nrows = n_obs,
    ncols = p
  )
  assert_class(options, "McmcOptions")

  # Get or set the seed.
  r_seed <- try(get(".Random.seed", envir = .GlobalEnv), silent = TRUE)
  if (is(r_seed, "try-error")) {
    set.seed(floor(runif(n = 1, min = 0, max = 1e4)))
    r_seed <- get(".Random.seed", envir = .GlobalEnv)
  }
  # .Random.seed contains two leading integers where the second
  # gives the position in the following 624 long vector (see
  # ?set.seed). Take the current position and ensure positivity.
  r_seed <- abs(r_seed[-c(1:2)][r_seed[2]])

  # Build the JAGS model.
  bugs_model <- function() {
    for (i in 1:nObs) {
      y[i] ~ dbern(p[i])
      logit(p[i]) <- mu[i]
    }

    mu <- X[,] %*% beta

    ## the multivariate normal prior on the coefficients
    beta ~ dmnorm(priorMean[], priorPrec[,])
  }

  # Write the model file.
  model_file_name <- h_jags_write_model(bugs_model)

  jags_model <- rjags::jags.model(
    model_file_name,
    data = list(
      "X" = X,
      "y" = y,
      "nObs" = n_obs,
      priorMean = m0,
      priorPrec = P0
    ),
    quiet = TRUE,
    # Add the RNG seed to the inits list (use Mersenne Twister as per R default).
    inits = list(
      .RNG.name = "base::Mersenne-Twister",
      .RNG.seed = r_seed
    ),
    n.chains = 1,
    n.adapt = 0
  )

  # Burn in.
  update(jags_model, n.iter = options@burnin, progress.bar = "none")

  # Generate samples.
  # This is necessary because some outputs are written directly from the JAGS
  # compiled code to the outstream.
  samples <- NULL
  capture.output(
    samples <- rjags::jags.samples(
      model = jags_model,
      variable.names = "beta",
      n.iter = (options@iterations - options@burnin),
      thin = options@step,
      progress.bar = "none"
    )
  )

  t(samples$beta[,, 1L])
}


# mcmc-Data-LogisticIndepBeta ----

#' @describeIn mcmc Obtain posterior samples for the model parameters based on
#'   the pseudo [`LogisticIndepBeta`] DLE model. The joint prior and posterior
#'   probability density function of the intercept \eqn{\phi_1} (`phi1`) and the
#'   slope \eqn{\phi_2} (`phi2`) are given in
#'   \insertCite{WhiteheadWilliamson1998;textual}{crmPack}. However, since
#'   asymptotically, the joint posterior probability density will be bivariate
#'   normal, we use the bivariate normal distribution to generate posterior
#'   samples of the intercept and the slope parameters. For the prior samples of
#'   the intercept and the slope, a bivariate normal distribution with mean and
#'   the covariance matrix given in
#'   \insertCite{WhiteheadWilliamson1998;textual}{crmPack} is used.
#'
#' @aliases mcmc-Data-LogisticIndepBeta
#' @example examples/mcmc-LogisticIndepBeta.R
#' @references
#'   \insertAllCited{}
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "Data",
    model = "LogisticIndepBeta",
    options = "McmcOptions"
  ),
  def = function(data, model, options, ...) {
    # Update the DLE model first.
    this_model <- update(object = model, data = data)

    # Decide whether we sample from the prior or not.
    from_prior <- data@nObs == 0L

    # Probabilities of risk of DLE at all dose levels.
    pi <- (this_model@binDLE) / (this_model@DLEweights)
    # Scalar term for the covariance matrix.
    scalar_i <- this_model@DLEweights * pi * (1 - pi)

    precision <- matrix(rep(0, 4), nrow = 2, ncol = 2)

    for (i in seq_len(length(this_model@binDLE))) {
      precision_mat <- scalar_i[i] *
        matrix(
          c(
            1,
            log(this_model@DLEdose[i]),
            log(this_model@DLEdose[i]),
            (log(this_model@DLEdose[i]))^2
          ),
          2,
          2
        )
      precision <- precision + precision_mat
    }

    if (from_prior) {
      # Sample from the (asymptotic) bivariate normal prior for theta.
      tmp <- mvtnorm::rmvnorm(
        n = size(options),
        mean = c(slot(this_model, "phi1"), slot(this_model, "phi2")),
        sigma = solve(precision)
      )

      samples <- list(
        phi1 = tmp[, 1],
        phi2 = tmp[, 2]
      )
    } else {
      weights <- rep(1, length(data@y))
      # Probabilities of risk of DLE at all dose levels.
      pi <- (data@y) / weights
      # Scalar term for the covariance matrix.
      scalar_i <- weights * pi * (1 - pi)

      prior_dle <- this_model@binDLE
      prior_w1 <- this_model@DLEweights
      prior_dose <- this_model@DLEdose

      fit_dle <- suppressWarnings(glm(
        prior_dle / prior_w1 ~ log(prior_dose),
        family = binomial(link = "logit"),
        weights = prior_w1
      ))
      s_fit_dle <- summary(fit_dle)

      # Obtain parameter estimates for dose-DLE curve.
      prior_phi1 <- coef(s_fit_dle)[1, 1]
      prior_phi2 <- coef(s_fit_dle)[2, 1]

      # Use fast special sampler here.
      # Set up design matrix.
      X <- cbind(1, log(data@x))
      init_res <- myBayesLogit(
        y = data@y,
        X = X,
        m0 = c(prior_phi1, prior_phi2),
        P0 = precision,
        options = options
      )

      # Form the samples list.
      samples <- list(
        phi1 = init_res[, 1],
        phi2 = init_res[, 2]
      )
    }

    # Form a Samples object for return.
    Samples(
      data = samples,
      options = options
    )
  }
)

# mcmc-DataDual-Effloglog ----

#' @describeIn mcmc Obtain the posterior samples for the model parameters in the
#'   [`Effloglog`] model. Given the value of \eqn{\nu}, the precision of the
#'   efficacy responses, the joint prior or the posterior probability of the
#'   intercept \eqn{\theta_1} (`theta1`) and the slope \eqn{\theta_2} (`theta2`)
#'   is a bivariate normal distribution. The \eqn{\nu} (`nu`), the precision of
#'   the efficacy responses is either a fixed value or has a gamma distribution.
#'   If a gamma distribution is used, the samples of `nu` will be first generated.
#'   Then the mean of the `nu` samples will be used to generate samples of the
#'   intercept and slope parameters of the model.
#'
#' @aliases mcmc-DataDual-Effloglog
#' @example examples/mcmc-Effloglog.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataDual",
    model = "Effloglog",
    options = "McmcOptions"
  ),
  def = function(data, model, options, ...) {
    model <- update(object = model, data = data)
    sample_size <- size(options)

    if (model@use_fixed) {
      nu <- model@nu
      nu_samples <- rep(nu, sample_size)
    } else {
      nu_samples <- rgamma(
        sample_size,
        shape = model@nu["a"],
        rate = model@nu["b"]
      )
      nu <- mean(nu_samples)
    }

    # Sample from the (asymptotic) bivariate normal prior for theta1 and theta2.
    tmp <- mvtnorm::rmvnorm(
      n = sample_size,
      mean = model@mu,
      sigma = solve(nu * model@Q)
    )

    samples <- list(
      theta1 = tmp[, 1],
      theta2 = tmp[, 2],
      nu = nu_samples
    )

    Samples(
      data = samples,
      options = options
    )
  }
)

# mcmc-DataDual-EffFlexi ----

#' @describeIn mcmc Obtain the posterior samples for the estimates in the
#'   [`EffFlexi`] model. This is the MCMC procedure based on what is described
#'   in \insertCite{LangBrezger2004;textual}{crmPack} such that samples of the
#'   mean efficacy responses at all dose levels, samples of `sigma2`
#'   \eqn{\sigma^2}, the variance of the efficacy response and samples of
#'   `sigma2betaW` \eqn{\sigma^2_{\beta_W}}, the variance of the random walk
#'   model will be generated. Please refer to
#'   \insertCite{LangBrezger2004;textual}{crmPack} for the procedures and the
#'   form of the joint prior and posterior probability density for the mean
#'   efficacy responses. In addition, both `sigma2` and `sigma2betaW` can be
#'   fixed or have an inverse-gamma prior and posterior distribution. Therefore,
#'   if the inverse gamma distribution(s) are used, the parameters in the
#'   distribution will be first updated and then samples of `sigma2` and
#'   `sigma2betaW` will be generated using the updated parameters.
#'
#' @aliases mcmc-DataDual-EffFlexi
#' @example examples/mcmc-EffFlexi.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataDual",
    model = "EffFlexi",
    options = "McmcOptions"
  ),
  def = function(data, model, options, ...) {
    # Update the model.
    this_model <- update(object = model, data = data)

    n_samples <- size(options)

    # Prepare samples container.
    samples <- list(
      ExpEff = matrix(ncol = data@nGrid, nrow = n_samples),
      sigma2W = matrix(nrow = n_samples),
      sigma2betaW = matrix(nrow = n_samples)
    )

    # Index of the next sample to be saved.
    iter_save <- 1L

    # Monitoring the Metropolis-Hastings update for sigma2.
    accept_history <- list(sigma2W = logical(options@iterations))

    # Current parameter values and starting values for the MCMC.
    if (length(data@w) == 0) {
      w1 <- this_model@eff
      x1 <- this_model@eff_dose
    } else {
      # Combine pseudo data with observed efficacy responses and no DLT observed.
      eff_obsrv <- getEff(data, no_dlt = TRUE)
      w1 <- c(this_model@eff, eff_obsrv$w_no_dlt)
      x1 <- c(this_model@eff_dose, eff_obsrv$x_no_dlt)
    }
    x1_level <- match_within_tolerance(x1, data@doseGrid)

    # betaW is constant, the average of the efficacy values.
    beta_w <- rep(mean(w1), data@nGrid)

    # sigma2betaW: use fixed value or prior mean.
    sigma2_beta_w <-
      if (this_model@use_fixed[["sigma2betaW"]]) {
        this_model@sigma2betaW
      } else {
        this_model@sigma2betaW["b"] / (this_model@sigma2betaW["a"] - 1)
      }

    # sigma2: fixed value or just the empirical variance.
    sigma2_w <- if (this_model@use_fixed[["sigma2W"]]) {
      this_model@sigma2W
    } else {
      var(w1)
    }

    # Set up diagonal matrix with the number of patients in corresponding dose levels.
    design_w_crossprod <- crossprod(this_model@X)

    # The MCMC cycle.
    for (iter_mcmc in seq_len(options@iterations)) {
      # 1) Generate coefficients for the Flexible Efficacy model.
      adjusted_var <- sigma2_w
      # New precision matrix.
      this_prec_w <- design_w_crossprod /
        adjusted_var +
        this_model@RW / sigma2_beta_w
      # Draw random normal vector.
      norm_vec <- rnorm(data@nGrid)
      # And its Cholesky factor.
      this_prec_w_chol <- chol(this_prec_w)
      # Solve betaW for L^T * betaW = normVec.
      beta_w <- backsolve(r = this_prec_w_chol, x = norm_vec)
      # The residual.
      adjusted_w <- w1 - this_model@X %*% beta_w

      # Forward substitution: solve L^T * tmp = designW^T * adjustedW / adjustedVar.
      tmp <- forwardsolve(
        l = this_prec_w_chol,
        x = crossprod(this_model@X, adjusted_w) / adjusted_var,
        upper.tri = TRUE,
        transpose = TRUE
      )
      # Backward substitution: solve R * result = tmp (where R is the Cholesky factor).
      tmp <- backsolve(
        r = this_prec_w_chol,
        x = tmp
      )

      # tmp is the mean vector of the distribution.
      # Add tmp to betaW to obtain final sample.
      beta_w <- beta_w + tmp

      # 2) Generate prior variance factor for the random walk.
      # If fixed, do nothing. Otherwise sample from full conditional.
      if (!this_model@use_fixed[["sigma2betaW"]]) {
        sigma2_beta_w <- rinvGamma(
          n = 1L,
          a = this_model@sigma2betaW["a"] + this_model@RW_rank / 2,
          b = this_model@sigma2betaW["b"] +
            crossprod(beta_w, this_model@RW %*% beta_w) / 2
        )
      }

      # 3) Generate variance for the flexible efficacy model.
      # If fixed variance is used, do nothing.
      if (this_model@use_fixed[["sigma2W"]]) {
        accept_history$sigma2W[iter_mcmc] <- TRUE
      } else {
        # Metropolis-Hastings update step here, using an inverse gamma distribution.
        a_star <- this_model@sigma2W["a"] + length(x1) / 2
        # Second parameter bStar depends on the value for sigma2W.
        b_star <- function(x) {
          adj_w <- w1
          sum((adj_w - beta_w[x1_level])^2) / 2 + this_model@sigma2W["b"]
        }
        # Draw proposal.
        b_star_proposal <- b_star(sigma2_w)
        sigma2_w <- rinvGamma(n = 1L, a = a_star, b = b_star_proposal)
      }

      # 4) Save samples.
      if (saveSample(options, iter_mcmc)) {
        samples$ExpEff[iter_save, ] <- beta_w
        samples$sigma2W[iter_save, 1] <- sigma2_w
        samples$sigma2betaW[iter_save, 1] <- sigma2_beta_w
        iter_save <- iter_save + 1L
      }
    }

    Samples(
      data = samples,
      options = options
    )
  }
)

# mcmc-DataOrdinal-LogisticLogNormalOrdinal ----

#' @describeIn mcmc Obtain the posterior samples for the model parameters in the
#'   [`LogisticLogNormalOrdinal`] model.
#'
#'   The generic `mcmc` method returns a [`Samples`] object with elements of the
#'   `data` slot named `alpha[1]`, `alpha[2]`, ..., `alpha[k]` and `beta` when
#'   passed a [`LogisticLogNormalOrdinal`] object. This makes the "alpha elements"
#'   awkward to access and is inconsistent with other model objects. So rename
#'   the alpha elements to `alpha1`, `alpha2`, ..., `alpha<k>` for ease and
#'   consistency.
#'
#' @aliases mcmc-DataOrdinal-LogisticLogNormalOrdinal
#' @example examples/mcmc-LogisticLogNormalOrdinal.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataOrdinal",
    model = "LogisticLogNormalOrdinal",
    options = "McmcOptions"
  ),
  def = function(data, model, options, ...) {
    # Obtain samples using the default method, but...
    return_value <- callNextMethod()
    # ...rename the alpha elements from alpha[<k>] to alpha<k>, where <k> is an
    # integer.
    names(return_value@data) <- gsub(
      "\\[(\\d+)\\]",
      "\\1",
      names(return_value@data)
    )
    return_value
  }
)

#' Helper Function to Set and Save the RNG Seed
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This code is basically copied from `stats:::simulate.lm`.
#'
#' @param seed an object specifying if and how the random number generator
#' should be initialized ("seeded"). Either `NULL` (default) or an
#' integer that will be used in a call to [set.seed()] before
#' simulating the response vectors. If set, the value is saved as the
#' `seed` slot of the returned object. The default, `NULL` will
#' not change the random generator state.
#' @return The integer vector containing the random number generate state will
#' be returned, in order to call this function with this input to reproduce
#' the obtained simulation results.
#'
#' @export
set_seed <- function(seed = NULL) {
  assert_number(seed, null.ok = TRUE)

  if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    runif(1)
  }

  if (is.null(seed)) {
    get(".Random.seed", envir = .GlobalEnv)
  } else {
    seed <- as.integer(seed)
    r_seed <- get(".Random.seed", envir = .GlobalEnv)
    # Make sure r_seed exists in parent frame.
    assign(".r_seed", r_seed, envir = parent.frame())
    set.seed(seed)
    # Here we need the r_seed in the parent.frame!
    do.call(
      "on.exit",
      list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))),
      envir = parent.frame()
    )
    structure(seed, kind = as.list(RNGkind()))
  }
}

#' Helper Function to Obtain Simulation Results List
#'
#' The function `fun` can use variables that are visible to itself.
#' The names of these variables have to be given in the vector `vars`.
#'
#' @param fun (`function`)\cr the simulation function for a single iteration, which takes as
#' single parameter the iteration index.
#' @param nsim number of simulations to be conducted.
#' @param vars names of the variables.
#' @param parallel should the simulation runs be parallelized across the
#' clusters of the computer?
#' @param n_cores how many cores should be used for parallel computing?
#' @return The list with all simulation results (one iteration corresponds
#' to one list element).
#'
#' @importFrom parallel makeCluster
#' @importFrom parallelly availableCores
#' @keywords internal programming
get_result_list <- function(
  fun,
  nsim,
  vars,
  parallel,
  n_cores
) {
  assert_flag(parallel)
  assert_integerish(n_cores, lower = 1)

  if (!parallel) {
    lapply(
      X = seq_len(nsim),
      FUN = fun
    )
  } else {
    # Process all simulations.
    cores <- min(
      as.integer(n_cores),
      parallelly::availableCores()
    )

    # Start the cluster.
    cl <- parallel::makeCluster(cores)

    # Load the required R package.
    parallel::clusterEvalQ(cl, {
      library(crmPack)
      NULL
    })

    # Export local variables from the caller environment.
    # Note: parent.frame() is different from parent.env() which returns
    # the environment where this function has been defined!
    parallel::clusterExport(
      cl = cl,
      varlist = vars,
      envir = parent.frame()
    )

    # Export all global variables.
    parallel::clusterExport(
      cl = cl,
      varlist = ls(.GlobalEnv)
    )

    # Load user extensions from global options.
    crmpack_extensions <- getOption("crmpack_extensions")
    if (is.null(crmpack_extensions) != TRUE) {
      tryCatch(
        {
          parallel::clusterCall(cl, crmpack_extensions)
        },
        error = function(e) {
          stop("Failed to export crmpack_extensions: ", e$message)
        }
      )
    }

    # Do the computations in parallel.
    res <- parallel::parLapply(
      cl = cl,
      X = seq_len(nsim),
      fun = fun
    )

    # Stop the cluster.
    parallel::stopCluster(cl)

    res
  }
}


#' Helper Function to call truth calculation
#'
#' @param dose (`number`)\cr current dose.
#' @param truth (`function`)\cr defines the true probability for a DLT at a dose.
#' @param this_args (`data.frame`)\cr list of arguments for the truth.
#' @return The updated `this_truth`.
#'
#' @keywords internal
h_this_truth <- function(dose, this_args, truth) {
  do.call(
    truth,
    ## First argument: the dose
    c(
      dose,
      ## Following arguments
      this_args
    )
  )
}


#' Helper Function to create return list for Simulations output
#'
#' @param resultList (`list`)\cr raw iteration output.
#'
#' @return aggregated output for simulation object `list`.
#'
#' @keywords internal
h_simulations_output_format <- function(resultList) {
  ## put everything in the Simulations format:

  ## setup the list for the simulated data objects
  dataList <- lapply(resultList, "[[", "data")

  ## the vector of the final dose recommendations
  recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

  ## setup the list for the final fits
  fitList <- lapply(resultList, "[[", "fit")

  ## the reasons for stopping
  stopReasons <- lapply(resultList, "[[", "stop")

  # individual stopping rule results as matrix, labels as column names
  stopResults <- lapply(resultList, "[[", "report_results")
  stop_matrix <- as.matrix(do.call(rbind, stopResults))

  # Result list of additional statistical summary.
  additional_stats <- lapply(resultList, "[[", "additional_stats")

  list(
    dataList = dataList,
    recommendedDoses = recommendedDoses,
    fitList = fitList,
    stopReasons = stopReasons,
    stopResults = stopResults,
    additional_stats = additional_stats,
    stop_matrix = stop_matrix
  )
}


#' Helper function to recursively unpack stopping rules and return lists with
#' logical value and label given
#'
#' @param stopit_tree object from simulate method
#' @return named list

h_unpack_stopit <- function(stopit_tree) {
  label <- attr(stopit_tree, "report_label")
  value <- stopit_tree[1]
  names(value) <- label
  value
  if (is.null(attr(stopit_tree, "individual"))) {
    value
  } else {
    unlist(c(
      value,
      lapply(attr(stopit_tree, "individual"), h_unpack_stopit)
    ))
  }
}


#' Helper function to determine the dlts including first separate and placebo
#' condition
#'
#' @param data (`Data`)\cr what data to start from.
#' @param dose (`number`)\cr current dose.
#' @param prob (`function`)\cr defines the true probability for a DLT at a dose.
#' @param prob_placebo (`function`)\cr defines the true probability for a DLT at a placebo condition.
#' @param cohort_size (`number`)\cr the cohort size to use.
#' @param cohort_size_placebo (`number`)\cr the cohort size to use for placebo condition.
#' @param dose_grid (`numeric`)\cr the dose_grid as specified by the user.
#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
#' @return updated data object
#' @keywords internal

h_determine_dlts <- function(
  data,
  dose,
  prob,
  prob_placebo,
  cohort_size,
  cohort_size_placebo,
  dose_grid,
  first_separate
) {
  assert_class(data, "Data")
  assert_number(dose)
  assert_number(prob)
  assert_number(cohort_size)
  assert_flag(first_separate)

  if (first_separate && cohort_size > 1) {
    dlts <- rbinom(n = 1, size = 1, prob = prob)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
    }
    if (dlts == 0) {
      dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
      if ((data@placebo) && cohort_size_placebo > 0) {
        dlts_placebo <- c(
          dlts_placebo,
          rbinom(
            n = cohort_size_placebo, # cohort_size_placebo - 1?
            size = 1,
            prob = prob_placebo
          )
        )
      }
    }
  } else {
    dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(
        n = cohort_size_placebo,
        size = 1,
        prob = prob_placebo
      )
    }
  }

  if ((data@placebo) && cohort_size_placebo > 0) {
    this_data <- update(
      object = data,
      x = dose_grid,
      y = dlts_placebo,
      check = FALSE
    )

    ## update the data with active dose
    this_data <- update(
      object = this_data,
      x = dose,
      y = dlts,
      new_cohort = FALSE
    )
  } else {
    ## update the data with this cohort
    this_data <- update(
      object = data,
      x = dose,
      y = dlts
    )
  }
  this_data
}

#' Internal Helper Functions for Validation of [`GeneralData`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralData`] or inherited classes and therefore not exported.
#'
#' @name v_data_objects
#' @param object (`GeneralData`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_data_objects validates that the [`GeneralData`]
#'   object contains unique `ID`, non-negative `cohort` indices and
#'   `ID` and `cohort` vectors are of the same length `nObs`.
v_general_data <- function(object) {
  v <- Validate()
  # In if clause so that below test_* won't fail.
  if (!test_int(object@nObs)) {
    return("nObs must be of type integer of length 1")
  }
  v$check(
    test_integer(
      object@ID,
      len = object@nObs,
      any.missing = FALSE,
      unique = TRUE,
      null.ok = TRUE
    ),
    "ID must be of type integer and length nObs and unique"
  )
  v$check(
    test_integer(
      object@cohort,
      lower = 0L,
      len = object@nObs,
      any.missing = FALSE,
      sorted = TRUE
    ),
    "cohort must be of type integer and length nObs and contain non-negative, sorted values"
  )
  v$result()
}

#' @describeIn v_data_objects helper function which verifies whether
#'   the `dose` values are unique in each and every different `cohort`.
#' @param dose (`numeric`)\cr dose values.
#' @param cohort (`integer`)\cr cohort indices parallel to `doses`.
#' @return `TRUE` if `dose` is unique per `cohort`, otherwise `FALSE`.
h_doses_unique_per_cohort <- function(dose, cohort) {
  assert_numeric(dose)
  assert_integer(cohort)

  num_doses_per_cohort <- tapply(
    X = dose,
    INDEX = cohort,
    FUN = function(d) length(unique(d))
  )
  all(num_doses_per_cohort == 1L)
}

#' Helper Function performing validation Common to Data and DataOrdinal
#'
#' @rdname h_validate_common_data_slots
#' @param object (`Data` or `DataOrdinal`)\cr the object to be validated
#' @returns a `Validate` object containing the result of the validation
h_validate_common_data_slots <- function(object) {
  v <- Validate()
  v$check(
    test_double(object@x, len = object@nObs, any.missing = FALSE),
    "Doses vector x must be of type double and length nObs"
  )
  v$check(
    test_double(
      object@doseGrid,
      len = object@nGrid,
      any.missing = FALSE,
      unique = TRUE,
      sorted = TRUE
    ),
    "doseGrid must be of type double and length nGrid and contain unique, sorted values"
  )
  v$check(
    test_int(object@nGrid),
    "Number of dose grid values nGrid must be scalar integer"
  )
  v$check(
    test_integer(object@xLevel, len = object@nObs, any.missing = FALSE),
    "Levels xLevel for the doses the patients have been given must be of type integer and length nObs"
  )
  v$check(
    test_flag(object@placebo),
    "The placebo flag must be scalar logical"
  )
  v$check(
    test_subset(object@x, object@doseGrid),
    "Dose values in x must be from doseGrid"
  )
  v$check(
    h_all_equivalent(object@x, object@doseGrid[object@xLevel]),
    "x must be equivalent to doseGrid[xLevel] (up to numerical tolerance)"
  )
  if (!object@placebo) {
    v$check(
      h_doses_unique_per_cohort(dose = object@x, cohort = object@cohort),
      "There must be only one dose level per cohort"
    )
  }
  v
}

#' @describeIn v_data_objects validates that the [`Data`] object contains
#'   valid elements with respect to their types, dependency and length.
v_data <- function(object) {
  v <- h_validate_common_data_slots(object)
  v$check(
    test_integer(
      object@y,
      lower = 0,
      upper = 1,
      len = object@nObs,
      any.missing = FALSE
    ),
    "DLT vector y must be nObs long and contain 0 or 1 integers only"
  )

  v$result()
}

#' @describeIn v_data_objects validates that the [`DataDual`] object
#' contains valid biomarker vector with respect to its type and the length.
v_data_dual <- function(object) {
  v <- Validate()
  v$check(
    test_double(object@w, len = object@nObs, any.missing = FALSE),
    "Biomarker vector w must be of type double and length nObs"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataParts`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_parts <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@part,
      lower = 1,
      upper = 2,
      len = object@nObs,
      any.missing = FALSE
    ),
    "vector part must be nObs long and contain 1 or 2 integers only"
  )
  v$check(
    test_int(object@nextPart, lower = 1, upper = 2),
    "nextPart must be integer scalar 1 or 2"
  )
  v$check(
    test_numeric(
      object@part1Ladder,
      any.missing = FALSE,
      sorted = TRUE,
      unique = TRUE
    ),
    "part1Ladder must be of type double and contain unique, sorted values"
  )
  v$check(
    test_subset(object@part1Ladder, object@doseGrid),
    "part1Ladder must have all entries from doseGrid"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataMixture`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_mixture <- function(object) {
  v <- Validate()

  # In if clause so that below test_* won't fail.
  if (!test_int(object@nObsshare)) {
    return("nObsshare must be of type integer of length 1")
  }
  v$check(
    test_numeric(object@xshare, len = object@nObsshare, any.missing = FALSE),
    "Dose vector xshare must be of type double and length nObsshare"
  )
  v$check(
    test_integer(
      object@yshare,
      lower = 0,
      upper = 1,
      len = object@nObsshare,
      any.missing = FALSE
    ),
    "DLT vector yshare must be nObsshare long and contain 0 or 1 integers only"
  )
  v$check(
    test_subset(object@xshare, object@doseGrid),
    "Dose values in xshare must be from doseGrid"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataDA`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_da <- function(object) {
  v <- Validate()
  # In if clause so that below test_* won't fail.
  if (!(test_number(object@Tmax) && object@Tmax > 0)) {
    return(
      "DLT window Tmax must be of type double of length 1 and greater than 0"
    )
  }
  v$check(
    test_numeric(
      object@u,
      upper = object@Tmax,
      len = object@nObs,
      any.missing = FALSE
    ) &&
      all(object@u >= 0),
    "u must be of type double, nObs length, non-negative, not missing and not greater than Tmax"
  )
  v$check(
    test_numeric(
      object@t0,
      lower = 0,
      len = object@nObs,
      any.missing = FALSE,
      sorted = TRUE
    ),
    "t0 must be of type double, nObs length, sorted non-negative"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataOrdinal`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_ordinal <- function(object) {
  v <- h_validate_common_data_slots(object)
  v$check(
    test_integer(
      object@y,
      lower = 0,
      upper = length(object@yCategories) - 1,
      len = object@nObs,
      any.missing = FALSE
    ),
    "DLT vector y must be nObs long and contain integers between 0 and k-1 only, where k is the length of the vector in the yCategories slot" # nolint
  )
  v$check(
    length(unique(names(object@yCategories))) ==
      length(names(object@yCategories)),
    "yCategory labels must be unique"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataGrouped`] object
#'   contains valid group information.
v_data_grouped <- function(object) {
  v <- Validate()
  v$check(
    test_factor(
      object@group,
      levels = c("mono", "combo"),
      len = object@nObs,
      any.missing = FALSE
    ),
    "group must be factor with levels mono and combo of length nObs without missings"
  )
  v$result()
}

#' Update [`DualEndpoint`] class model components with regard to biomarker
#' regression variance.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] model existing components
#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
#' to biomarker regression variance `sigma2W`.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for the biomarker
#'   regression variance `sigma2W` should be used or not. If `sigma2W` is not
#'   supposed to be a fixed value, a prior distribution from the Inverse-Gamma
#'   distribution will be used. See the details below, under `sigma2W` argument.
#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @param comp (`list`)\cr a named list with model components that will be updated.
#'   The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
#'   definitions of the components, see [`GeneralModel`] class.
#'   The `modelspecs` and `init` components on `comp` list are specified up to
#'   the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
#'   functions. These bodies are simply a lists itself.
#'
#' @return `list` with updated model components.
#'
#' @export
h_model_dual_endpoint_sigma2w <- function(
  use_fixed, # nolintr
  sigma2W,
  comp
) {
  if (use_fixed) {
    assert_number(sigma2W, lower = 0 + .Machine$double.xmin, finite = TRUE)
    comp$modelspecs$precW <- 1 / sigma2W
  } else {
    assert_true(h_test_named_numeric(sigma2W, permutation.of = c("a", "b")))
    comp$priormodel <- h_jags_join_models(
      comp$priormodel,
      function() {
        precW ~ dgamma(precWa, precWb)
      }
    )
    comp$modelspecs$precWa <- sigma2W[["a"]]
    comp$modelspecs$precWb <- sigma2W[["b"]]
    comp$init$precW <- 1
    comp$sample <- c(comp$sample, "precW")
  }
  comp
}

#' Update [`DualEndpoint`] class model components with regard to DLT and biomarker
#' correlation.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] model existing components
#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
#' DLT and biomarker correlation `rho`.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for DLT and
#'   biomarker correlation `rho` should be used or not. If `rho` is not supposed
#'   to be a fixed value, a prior distribution from the scaled Beta family will
#'   be used. See the details below, under `rho` argument.
#' @param rho (`numeric`)\cr DLT and biomarker correlation. It must be either a
#'   fixed value (between `-1` and `1`), or a named vector with two elements,
#'   named `a` and `b` for the Beta prior on the transformation
#'   `kappa = (rho + 1) / 2`, which is in `(0, 1)`. For example, `a = 1, b = 1`
#'   leads to a uniform prior on `rho`.
#' @param comp (`list`)\cr a named list with model components that will be updated.
#'   The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
#'   definitions of the components, see [`GeneralModel`] class.
#'   The `modelspecs` and `init` components on `comp` list are specified up to
#'   the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
#'   functions. These bodies are simply a lists itself.
#'
#' @return A `list` with updated model components.
#'
#' @export
h_model_dual_endpoint_rho <- function(use_fixed, rho, comp) {
  rmin <- .Machine$double.xmin
  if (use_fixed) {
    assert_number(rho, lower = -1 + rmin, upper = 1 - rmin)
    comp$modelspecs$rho <- rho
  } else {
    assert_true(h_test_named_numeric(rho, permutation.of = c("a", "b")))
    comp$priormodel <- h_jags_join_models(
      comp$priormodel,
      function() {
        kappa ~ dbeta(rhoa, rhob)
        rho <- 2 * kappa - 1
      }
    )
    comp$modelspecs$rhoa <- rho[["a"]]
    comp$modelspecs$rhob <- rho[["b"]]
    comp$init$kappa <- 0.5
    comp$sample <- c(comp$sample, "rho")
  }
  comp
}

#' Update certain components of [`DualEndpoint`] model with regard to prior variance
#' factor of the random walk.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] object and updates
#' `priormodel`, `modelspecs`, `init`, `sample` slots according to the random walk
#' variance.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for
#'   `sigma2betaW` should be used or not. If `sigma2betaW` is not supposed
#'   to be a fixed value, a prior distribution from the Inverse-Gamma distribution
#'   will be used. See the details below, under `sigma2betaW` argument.
#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
#'
#' @return A [`DualEndpoint`] model with updated `priormodel`, `modelspecs`,
#'   `init`, `sample` slots.
#'
#' @seealso [`DualEndpointRW`].
#' @export
h_model_dual_endpoint_sigma2betaw <- function(
  use_fixed, # nolintr
  sigma2betaW,
  de
) {
  modelspecs <- de@modelspecs
  init <- de@init

  if (use_fixed) {
    assert_number(sigma2betaW, lower = 0 + .Machine$double.xmin, finite = TRUE)
    ms <- list(precBetaW = 1 / sigma2betaW)
  } else {
    assert_true(h_test_named_numeric(sigma2betaW, permutation.of = c("a", "b")))
    # gamma prior for random walk precision.
    de@priormodel <- h_jags_join_models(
      de@priormodel,
      function() {
        precBetaW ~ dgamma(precBetaWa, precBetaWb)
      }
    )
    ms <- list(precBetaWa = sigma2betaW[["a"]], precBetaWb = sigma2betaW[["b"]])
    de@init <- function(y) {
      c(init(y), list(precBetaW = 1))
    }
    de@sample <- c(de@sample, "precBetaW")
  }
  de@modelspecs <- function(from_prior) {
    c(modelspecs(from_prior), ms)
  }
  de
}

#' Update certain components of [`DualEndpoint`] model with regard to parameters
#' of the function that models dose-biomarker relationship defined in the
#' [`DualEndpointBeta`] class.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] object and updates
#' `use_fixed`, `priormodel`, `modelspecs`, `init`, `sample` slots with regard
#' to a given parameter of the dose-biomarker relationship \eqn{f(x)} defined in
#' the [`DualEndpointBeta`] class. This update solely depends on whether a given
#' parameter's value `param` is a fixed-valued scalar or two-elements numeric
#' vector. In the later case, it is assumed that `param` represents two
#' parameters of a probability distribution that will be used in `priormodel`
#' function to generate values for the `param_name` parameter of \eqn{f(x)}.
#' See the help page for [`DualEndpointBeta`] class for more details.
#'
#' @param param (`numeric`)\cr the value of a given `param_name` parameter of
#'   the dose-biomarker relationship function \eqn{f(x)}. Either a fixed-valued
#'   scalar or vector with two elements that are the parameters of a probability
#'   distribution that will be used in `priormodel` function to generate values
#'   for the `param_name` parameter of \eqn{f(x)}.
#' @param param_name (`string`)\cr the name of the parameter of \eqn{f(x)},
#'   whose value depends on `param`.
#' @param param_suffix (`character`)\cr the two suffixes to be appended to
#'   the elements of `param_name` and then used when updating `modelspecs`.
#'   The value of this argument is ignored when `param` is a scalar.
#' @param priormodel (`function` or `NULL`)\cr a function representing the
#'   `JAGS` prior specification that will be appended to existing
#'   `de@priormodel` specification if `param` is not a scalar. Otherwise,
#'   `de@priormodel` remains unchanged.
#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
#'
#' @return A [`DualEndpoint`] model with updated `use_fixed`, `priormodel`,
#'   `modelspecs`, `init`, `sample` slots.
#'
#' @export
h_model_dual_endpoint_beta <- function(
  param,
  param_name,
  param_suffix = c("_low", "_high"),
  priormodel = NULL,
  de
) {
  assert_numeric(param, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_string(param_name)
  assert_class(de, "DualEndpoint")

  use_fixed <- setNames(test_number(param), param_name)
  modelspecs <- de@modelspecs
  init <- de@init

  if (use_fixed) {
    ms <- setNames(list(param), param_name)
  } else {
    assert_character(param_suffix, len = 2, unique = TRUE, any.missing = FALSE)
    assert_function(priormodel)
    param_name2 <- paste0(param_name, param_suffix)

    de@priormodel <- h_jags_join_models(
      de@priormodel,
      priormodel
    )
    ms <- setNames(list(param[1], param[2]), param_name2)
    de@init <- function(y) {
      c(init(y), setNames(list(mean(param)), param_name))
    }
    de@sample <- c(de@sample, param_name)
  }
  de@modelspecs <- function(from_prior) {
    c(modelspecs(from_prior), ms)
  }
  de@use_fixed <- c(de@use_fixed, use_fixed)
  de
}

#' Convert an ordinal CRM model to the Equivalent Binary CRM Model for a Specific
#' Grade
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that takes a [`LogisticLogNormalOrdinal`] and an
#' integer grade and converts them to the equivalent `LogisticLogNormal` model.
#'
#' @param x (`LogisticLogNormalOrdinal`)\cr the `LogisticLogNormalOrdinal`
#'   model to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent model
#' is required.
#' @return A [`LogisticLogNormal`] model.
#'
#' @export
h_convert_ordinal_model <- function(x, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(x, "LogisticLogNormalOrdinal")
  # Execute
  LogisticLogNormal(
    mean = x@params@mean[-grade],
    cov = x@params@cov[-grade, -grade],
    ref_dose = x@ref_dose
  )
}

#' Internal Helper Functions for Validation of Model Parameters Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an object
#' with model parameters or inherited classes and therefore not exported.
#'
#' @name v_model_params
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_model_params a helper function that validates multivariate normal
#'   parameters.
#' @param object (`ModelParamsNormal`)\cr multivariate normal parameters object
#'   to validate.
v_model_params_normal <- function(object) {
  v <- Validate()

  v$check(
    test_numeric(x = object@mean, min.len = 2L, any.missing = FALSE),
    "mean must have length of at least 2 and no missing values are allowed"
  )
  is_cov_valid <- h_is_positive_definite(object@cov, length(object@mean))
  v$check(
    is_cov_valid,
    "cov must be positive-definite matrix without any missing values"
  )
  is_prec_valid <- h_is_positive_definite(object@prec, length(object@mean))
  v$check(
    is_prec_valid,
    "prec must be positive-definite matrix without any missing values"
  )
  if (is_cov_valid && is_prec_valid) {
    v$check(
      all.equal(
        object@cov %*% object@prec,
        diag(1, length(object@mean)),
        check.attributes = FALSE
      ) ==
        TRUE,
      "prec must be inverse of cov"
    )
  }
  v$result()
}

#' Internal Helper Functions for Validation of [`GeneralModel`] and [`ModelPseudo`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralModel`] and [`ModelPseudo`] or inherited classes and therefore are
#' not exported.
#'
#' @name v_model_objects
#' @param object (`GeneralModel`) or (`ModelPseudo`) \cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_model_objects validates that the names of the
#'   arguments in `init` function are included in `datanames` or `datanames_prior`
#'   slots.
v_general_model <- function(object) {
  v <- Validate()
  v$check(
    h_check_fun_formals(
      object@init,
      allowed = union(object@datanames, object@datanames_prior)
    ),
    "Arguments of the init function must be data names"
  )
  v$result()
}

#' @describeIn v_model_objects validates that the logistic Kadane model
#'   parameters are valid.
v_model_logistic_kadane <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@theta, bounds_closed = FALSE),
    "theta must be a probability scalar > 0 and < 1"
  )
  is_xmin_number <- test_number(object@xmin)
  v$check(is_xmin_number, "xmin must be scalar")

  is_xmax_number <- test_number(object@xmax)
  v$check(is_xmax_number, "xmax must be scalar")

  if (is_xmin_number && is_xmax_number) {
    v$check(
      object@xmin < object@xmax,
      "xmin must be strictly smaller than xmax"
    )
  }
  v$result()
}

#' @describeIn v_model_objects validates that the logistic Kadane model
#'   parameters with a beta and gamma prior are valid.
v_model_logistic_kadane_beta_gamma <- function(object) {
  # nolintr
  v <- Validate()
  v$check(
    test_number(object@alpha, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter alpha must be a positive scalar"
  )
  v$check(
    test_number(object@beta, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter beta must be a positive scalar"
  )
  v$check(
    test_number(object@shape, lower = .Machine$double.xmin, finite = TRUE),
    "Gamma distribution shape parameter must be a positive scalar"
  )
  v$check(
    test_number(object@rate, lower = .Machine$double.xmin, finite = TRUE),
    "Gamma distribution rate parameter must be a positive scalar"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `weightpar` is valid.
v_model_logistic_normal_mix <- function(object) {
  v <- Validate()
  v$check(
    h_test_named_numeric(object@weightpar, permutation.of = c("a", "b")),
    "weightpar must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `component` is a list with
#'   valid `ModelParamsNormal` objects as well as `weights` are correct.
v_model_logistic_normal_fixed_mix <- function(object) {
  # nolintr
  v <- Validate()
  v$check(
    all(sapply(object@components, test_class, "ModelParamsNormal")),
    "components must be a list with ModelParamsNormal S4 class objects"
  )
  comp_valid_result <- sapply(object@components, validObject, test = TRUE)
  comp_valid <- sapply(comp_valid_result, isTRUE)
  v$check(
    all(comp_valid),
    paste(
      "components must be a list with valid ModelParamsNormal S4 class objects",
      paste(unlist(comp_valid_result[!comp_valid]), collapse = ", "),
      collapse = ", ",
      sep = ", "
    )
  )
  v$check(
    length(object@components) == length(object@weights),
    "components must have same length as weights"
  )
  v$check(
    test_numeric(
      object@weights,
      lower = .Machine$double.xmin,
      finite = TRUE,
      any.missing = FALSE
    ),
    "weights must be positive"
  )
  v$check(
    sum(object@weights) == 1,
    "weights must sum to 1"
  )
  v$check(
    test_flag(object@log_normal),
    "log_normal must be TRUE or FALSE"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `share_weight` represents probability.
v_model_logistic_log_normal_mix <- function(object) {
  # nolintr
  v <- Validate()
  v$check(
    test_probability(object@share_weight),
    "share_weight does not specify a probability"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpoint`] class slots are valid.
v_model_dual_endpoint <- function(object) {
  rmin <- .Machine$double.xmin
  v <- Validate()

  v$check(
    test_flag(object@use_log_dose),
    "use_log_dose must be TRUE or FALSE"
  )
  uf_sigma2W <- object@use_fixed["sigma2W"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2W'"
  )
  uf_rho <- object@use_fixed["rho"]
  v$check(
    test_flag(uf_rho),
    "use_fixed must be a named logical vector that contains name 'rho'"
  )

  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2W, lower = rmin, finite = TRUE),
      "sigma2W must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2W is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2W, permutation.of = c("a", "b")),
      "sigma2W must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  if (isTRUE(uf_rho)) {
    v$check(
      test_number(object@rho, lower = -1 + rmin, upper = 1 - rmin), # rmin is ignored here!
      "rho must be a number in (-1, 1)"
    )
  } else {
    # object@rho is a vector with parameters for Beta(a, b).
    v$check(
      h_test_named_numeric(object@rho, permutation.of = c("a", "b")),
      "rho must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointRW`] class slots are valid.
v_model_dual_endpoint_rw <- function(object) {
  v <- Validate()
  uf_sigma2W <- object@use_fixed["sigma2betaW"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2betaW'"
  )
  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(
        object@sigma2betaW,
        lower = .Machine$double.xmin,
        finite = TRUE
      ),
      "sigma2betaW must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2betaW is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2betaW, permutation.of = c("a", "b")),
      "sigma2betaW must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointBeta`] class slots are valid.
v_model_dual_endpoint_beta <- function(object) {
  v <- Validate()

  for (s in c("E0", "Emax", "delta1", "mode")) {
    rmin <- .Machine$double.xmin
    uf <- object@use_fixed[s]

    v$check(
      test_flag(uf),
      paste0(
        "use_fixed must be a named logical vector that contains name '",
        s,
        "'"
      )
    )
    if (isTRUE(uf)) {
      if (s %in% c("delta1", "mode")) {
        v$check(
          test_number(slot(object, s), lower = rmin, finite = TRUE),
          paste(s, "must be a positive and finite numerical scalar")
        )
      }
    } else {
      # s is a vector with parameters for Uniform(s[1], s[2]) prior.
      v$check(
        test_numeric(
          slot(object, s),
          lower = 0,
          finite = TRUE,
          any.missing = FALSE,
          len = 2,
          unique = TRUE,
          sorted = TRUE
        ),
        paste(
          s,
          "must be a numerical vector of length two with non-negative, finite, unique and sorted (asc.) values"
        )
      )
    }
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointEmax`] class slots are valid.
v_model_dual_endpoint_emax <- function(object) {
  v <- Validate()

  for (s in c("E0", "Emax", "ED50")) {
    rmin <- .Machine$double.xmin
    uf <- object@use_fixed[s]

    v$check(
      test_flag(uf),
      paste0(
        "use_fixed must be a named logical vector that contains name '",
        s,
        "'"
      )
    )
    if (isTRUE(uf)) {
      v$check(
        test_number(slot(object, s), lower = rmin, finite = TRUE),
        paste(s, "must be a positive and finite numerical scalar")
      )
    } else {
      # s is a vector with parameters for Uniform(s[1], s[2]) prior.
      v$check(
        test_numeric(
          slot(object, s),
          lower = 0,
          finite = TRUE,
          any.missing = FALSE,
          len = 2,
          unique = TRUE,
          sorted = TRUE
        ),
        paste(
          s,
          "must be a numerical vector of length two with non-negative, finite, unique and sorted (asc.) values"
        )
      )
    }
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`LogisticIndepBeta`] class slots are valid.
v_model_logistic_indep_beta <- function(object) {
  v <- Validate()

  dle_len <- length(object@binDLE)
  v$check(
    test_numeric(
      object@binDLE,
      finite = TRUE,
      any.missing = FALSE,
      min.len = 2
    ),
    "binDLE must be a finite numerical vector of minimum length 2, without missing values"
  )
  v$check(
    test_numeric(
      object@DLEdose,
      finite = TRUE,
      any.missing = FALSE,
      len = dle_len
    ),
    "DLEdose must be a finite numerical vector of the same length as 'binDLE', without missing values"
  )
  v$check(
    test_integer(object@DLEweights, any.missing = FALSE, len = dle_len),
    "DLEweights must be an integer vector of the same length as 'binDLE', without missing values"
  )
  v$check(
    test_number(object@phi1),
    "phi1 must be a numerical scalar"
  )
  v$check(
    test_number(object@phi2),
    "phi2 must be a numerical scalar"
  )
  v$check(
    h_is_positive_definite(object@Pcov),
    "Pcov must be 2x2 positive-definite matrix without any missing values"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`Effloglog`] class slots are valid.
v_model_eff_log_log <- function(object) {
  rmin <- .Machine$double.xmin

  v <- Validate()
  v$check(
    test_numeric(object@eff, finite = TRUE, any.missing = FALSE, min.len = 2),
    "eff must be a finite numerical vector of minimum length 2, without missing values"
  )
  eff_dose_ok <- test_numeric(
    object@eff_dose,
    lower = rmin,
    finite = TRUE,
    any.missing = FALSE,
    len = length(object@eff)
  )
  v$check(
    eff_dose_ok,
    "eff_dose must be a finite numerical vector of the same length as 'eff', without missing values"
  )
  v$check(
    test_flag(object@use_fixed),
    "use_fixed must be a flag"
  )
  if (isTRUE(object@use_fixed)) {
    v$check(
      test_number(object@nu, lower = rmin, finite = TRUE),
      "nu must be a positive and finite numerical scalar"
    )
  } else {
    # object@nu is a vector with parameters for Gamma(a, b).
    v$check(
      h_test_named_numeric(object@nu, permutation.of = c("a", "b")),
      "nu must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  const_ok <- test_number(object@const, lower = 0)
  v$check(const_ok, "const must be a non-negative number")
  if (eff_dose_ok && const_ok) {
    v$check(
      min(object@data@doseGrid, object@eff_dose) > 1 - object@const,
      "For log-log model, doses and const must be such that dose + const > 1"
    )
  }
  v$check(
    test_number(object@theta1),
    "theta1 must be a numerical scalar"
  )
  v$check(
    test_number(object@theta2),
    "theta2 must be a numerical scalar"
  )
  nobs_no_dlt <- sum(!object@data@y)
  if (nobs_no_dlt + length(object@eff) > 2) {
    v$check(
      h_is_positive_definite(object@Pcov),
      "Pcov must be 2x2 positive-definite matrix without any missing values"
    )
  } else {
    v$check(
      test_matrix(object@Pcov, mode = "numeric", nrows = 2, ncols = 2) &&
        all(is.na(object@Pcov)),
      "Pcov must be 2x2 numeric matrix with all values missing if the length of combined data is 2"
    )
  }
  v$check(
    test_numeric(object@mu, finite = TRUE, len = 2),
    "mu must be a finite numerical vector of length 2"
  )
  Xnrow <- ifelse(nobs_no_dlt > 0, nobs_no_dlt, length(object@eff_dose))
  v$check(
    test_matrix(
      object@X,
      mode = "numeric",
      nrows = Xnrow,
      ncols = 2,
      any.missing = FALSE
    ),
    paste(
      "X must be a finite numerical matrix of size",
      Xnrow,
      "x 2, without any missing values"
    )
  )
  v$check(
    all(object@X[, 1] == 1),
    "X must be a design matrix, i.e. first column must be of 1s"
  )
  v$check(
    h_is_positive_definite(object@Q),
    "Q must be 2x2 positive-definite matrix without any missing values"
  )
  v$check(
    test_numeric(object@Y, finite = TRUE, any.missing = FALSE, len = Xnrow),
    paste(
      "Y must be a finite numerical vector of length",
      Xnrow,
      "and without any missing values"
    )
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`EffFlexi`] class slots are valid.
v_model_eff_flexi <- function(object) {
  rmin <- .Machine$double.xmin

  v <- Validate()
  v$check(
    test_numeric(object@eff, finite = TRUE, any.missing = FALSE, min.len = 2),
    "eff must be a finite numerical vector of minimum length 2, without missing values"
  )
  v$check(
    test_numeric(
      object@eff_dose,
      lower = rmin,
      finite = TRUE,
      any.missing = FALSE,
      len = length(object@eff)
    ),
    "eff_dose must be a finite numerical vector of the same length as 'eff', without missing values"
  )

  uf_sigma2W <- object@use_fixed["sigma2W"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2W'"
  )
  uf_sigma2betaW <- object@use_fixed["sigma2betaW"] # nolintr
  v$check(
    test_flag(uf_sigma2betaW),
    "use_fixed must be a named logical vector that contains name 'sigma2betaW'"
  )

  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2W, lower = rmin, finite = TRUE),
      "sigma2W must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2W is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2W, permutation.of = c("a", "b")),
      "sigma2W must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  if (isTRUE(uf_sigma2betaW)) {
    v$check(
      test_number(object@sigma2betaW, lower = rmin, finite = TRUE),
      "sigma2betaW must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2betaW is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2betaW, permutation.of = c("a", "b")),
      "sigma2betaW must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  v$check(
    test_flag(object@rw1),
    "rw1 must be a flag"
  )
  v$check(
    test_matrix(
      object@X,
      mode = "integer",
      ncols = object@data@nGrid,
      any.missing = FALSE
    ),
    paste(
      "X must be an integer matrix with",
      object@data@nGrid,
      "columns and without any missing values"
    )
  )
  v$check(
    all(object@X == 0L | object@X == 1L),
    "X must be a matrix with 0-1 values only"
  )
  v$check(
    test_matrix(
      object@RW,
      nrows = object@data@nGrid,
      ncols = object@data@nGrid,
      any.missing = FALSE
    ),
    paste0(
      "RW must be ",
      object@data@nGrid,
      "x",
      object@data@nGrid,
      " matrix without any missing values"
    )
  )
  v$check(
    test_int(object@RW_rank) &&
      (object@RW_rank ==
        (object@data@nGrid - ifelse(isTRUE(object@rw1), 1L, 2L))),
    "RW_rank must be an integer equal to data@nGrid - 2L"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`DALogisticLogNormal`] class slots are valid.
v_model_da_logistic_log_normal <- function(object) {
  v <- Validate()

  npiece_ok <- test_int(object@npiece)
  v$check(npiece_ok, "npiece must be a is a single integerish value")
  if (npiece_ok) {
    v$check(
      test_numeric(
        object@l,
        lower = 0,
        finite = TRUE,
        any.missing = FALSE,
        len = object@npiece
      ),
      "prior parameter vector l of lambda must be a non-negative vector of length equal to npiece"
    )
  }
  v$check(
    test_number(object@c_par, finite = TRUE),
    "c_par must be a finite numerical scalar"
  )
  v$check(
    test_flag(object@cond_pem),
    "cond_pem must be a flag"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`TITELogisticLogNormal`] class slots are valid.
v_model_tite_logistic_log_normal <- function(object) {
  # nolintr
  v <- Validate()
  v$check(
    test_string(object@weight_method, pattern = "^linear$|^adaptive$"),
    "weight_method must be a string equal either to linear or adaptive"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`OneParLogNormalPrior`] class slots are valid.
v_model_one_par_exp_normal_prior <- function(object) {
  # nolintr
  v <- Validate()

  is_skel_prob_ok <- test_probabilities(
    object@skel_probs,
    unique = TRUE,
    sorted = TRUE
  )
  v$check(
    is_skel_prob_ok,
    "skel_probs must be a unique sorted probability values between 0 and 1"
  )

  if (is_skel_prob_ok) {
    # Validating skel_fun/skel_fun_inv on within the range of skeleton probs.
    skel_probs_range <- range(object@skel_probs)
    # Probabilities within the range of skel_probs.
    probs_in_range <- seq(
      from = skel_probs_range[1],
      to = skel_probs_range[2],
      by = 0.01
    )
    # Interpolated dose grid.
    doses_in_range <- object@skel_fun_inv(probs_in_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_in_range), probs_in_range)),
      "skel_fun_inv must be an inverse funtion of skel_fun function on within the range of sekeleton probs"
    )

    # Validating skel_fun/skel_fun_inv on outside the range of skeleton probs.
    probs_out_range <- c(
      seq(from = 0, to = skel_probs_range[1], length.out = 3),
      seq(from = skel_probs_range[2], to = 1, length.out = 3)
    )
    doses_out_range <- object@skel_fun_inv(probs_out_range)
    v$check(
      isTRUE(all.equal(
        object@skel_fun(doses_out_range),
        rep(skel_probs_range, each = 3)
      )),
      "skel_fun_inv must be an inverse funtion of skel_fun function on outside the range of sekeleton probs"
    )
  }

  v$check(
    test_number(object@sigma2, lower = .Machine$double.xmin, finite = TRUE),
    "sigma2 must be a positive finite number"
  )

  v$result()
}

#' @describeIn v_model_objects validates that [`OneParExpPrior`] class slots are valid.
v_model_one_par_exp_prior <- function(object) {
  v <- Validate()

  is_skel_prob_ok <- test_probabilities(
    object@skel_probs,
    unique = TRUE,
    sorted = TRUE
  )
  v$check(
    is_skel_prob_ok,
    "skel_probs must be a unique sorted probability values between 0 and 1"
  )

  if (is_skel_prob_ok) {
    # Validating skel_fun/skel_fun_inv on within the range of skeleton probs.
    skel_probs_range <- range(object@skel_probs)
    # Probabilities within the range of skel_probs.
    probs_in_range <- seq(
      from = skel_probs_range[1],
      to = skel_probs_range[2],
      by = 0.01
    )
    # Interpolated dose grid.
    doses_in_range <- object@skel_fun_inv(probs_in_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_in_range), probs_in_range)),
      "skel_fun_inv must be an inverse funtion of skel_fun function on within the range of sekeleton probs"
    )

    # Validating skel_fun/skel_fun_inv on outside the range of skeleton probs.
    probs_out_range <- c(
      seq(from = 0, to = skel_probs_range[1], length.out = 3),
      seq(from = skel_probs_range[2], to = 1, length.out = 3)
    )
    doses_out_range <- object@skel_fun_inv(probs_out_range)
    v$check(
      isTRUE(all.equal(
        object@skel_fun(doses_out_range),
        rep(skel_probs_range, each = 3)
      )),
      "skel_fun_inv must be an inverse funtion of skel_fun function on outside the range of sekeleton probs"
    )
  }

  v$check(
    test_number(object@lambda, lower = .Machine$double.xmin, finite = TRUE),
    "lambda must be a positive finite number"
  )

  v$result()
}

#' @describeIn v_model_objects confirms that cov is diagonal
v_logisticlognormalordinal <- function(object) {
  v <- Validate()
  # diag(x) returns a vector, not a matrix, so cannot use identical(x, diag(x)
  x <- object@params@cov
  diag(x) <- rep(0, ncol(x))
  v$check(
    all(x == 0),
    "covariance matrix must be diagonal"
  )
  v$result()
}

#' @include helpers.R
#' @include ModelParams-validity.R
#' @include CrmPackClass-class.R
NULL

# ModelParamsNormal ----

## class ----

#' `ModelParamsNormal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`ModelParamsNormal`] is the class for a bivariate normal model parameters,
#' i.e. the mean vector, covariance matrix and precision matrix.
#' The precision matrix is an inverse of the covariance matrix in the
#' `JAGS` and it is computed internally by the object constructor function.
#'
#' @slot mean (`numeric`)\cr the mean vector.
#' @slot cov (`matrix`)\cr the covariance matrix.
#' @slot prec (`matrix`)\cr the precision matrix, which is an inverse matrix of the `cov`.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`].
#'
#' @aliases ModelParamsNormal
#' @export
#'
.ModelParamsNormal <- setClass(
  Class = "ModelParamsNormal",
  slots = c(
    mean = "numeric",
    cov = "matrix",
    prec = "matrix"
  ),
  contains = "CrmPackClass",
  validity = v_model_params_normal
)

## constructor ----

#' @rdname ModelParamsNormal-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#'
#' @export
#' @examples
#' ModelParamsNormal(mean = c(1, 6), cov = diag(2))
ModelParamsNormal <- function(mean, cov) {
  assert_matrix(
    cov,
    mode = "numeric",
    any.missing = FALSE,
    nrows = length(mean),
    ncols = length(mean)
  )
  # To ensure that `cov` is invertible:
  assert_true(h_is_positive_definite(cov, length(mean)))

  .ModelParamsNormal(
    mean = mean,
    cov = cov,
    prec = solve(cov)
  )
}

## default constructor ----

#' @rdname ModelParamsNormal-class
#' @note Typically, end users will not use the `.ModelPAramsNormal()` function.
#' @export
.DefaultModelParamsNormal <- function() {
  ModelParamsNormal(
    mean = c(1, 0),
    cov = matrix(c(1, 0, 0, 1), nrow = 2)
  )
}

# These functions will need to be amended to support the report_label slot if
# and when it is added to NextBest classes

# NextBestMTD ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param target_label (`character`)\cr the term used to describe the target
#' toxicity rate
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMTD
knit_print.NextBestMTD <- function(
  x,
  ...,
  target_label = "the 25th centile",
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(target_label, len = 1, any.missing = FALSE)

  tox_label <- h_prepare_labels(tox_label)
  # Execute
  rv <- paste0(
    "The dose level recommended for the next cohort will be selected as follows:\n\n",
    "-  First, ",
    target_label,
    " of the posterior distribution of ",
    tox_label[1],
    " will be calculated for all dose levels that are eligible according to the ",
    " Increments rule.\n",
    "-  Next, the \"target dose\" (which may not be part of the dose grid) for which ",
    target_label,
    " of the posterior distribution of ",
    tox_label[1],
    " is exactly equal to the target rate of ",
    x@target,
    " will be determined.\n",
    "- Finally, the dose level whose absolute distance from the target dose ",
    "is smallest will be selected as the recommended dose for the next cohort\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestNCRM ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestNCRM
knit_print.NextBestNCRM <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, max.len = 2, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be chosen in the following ",
    "way.  First, doses that are ineligible according to the increments rule ",
    "will be discarded.  Next, any dose for which the mean posterior probability of ",
    tox_label,
    " being in the overdose range - (",
    x@overdose[1],
    ", ",
    x@overdose[2],
    "] - is ",
    x@max_overdose_prob,
    " or more will also be discarded.  Finally, the dose amongst those remaining ",
    "which has the highest chance that the mean posterior probability of ",
    tox_label,
    " is in the target ",
    tox_label,
    " range of ",
    x@target[1],
    " to ",
    x@target[2],
    " (inclusive) will be selected.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestThreePlusThree ----

#' @description `r lifecycle::badge("experimental")`
#' @param label (`character`)\cr The term used to label the participants.
#' @param tox_label (`character`)\cr the term used to describe toxicity.  See
#' Usage Notes below.
#' See Usage Notes below.
#' @section Usage Notes:
#' This section describes the use of `label` and `tox_label`, collectively
#' referred to as `label`s.
#' A `label` should be a scalar or a vector of length 2.  If a scalar, it is
#' converted by adding a second element that is equal to the first, suffixed by `s`.
#' For example, `tox_label = "DLT"` becomes `tox_label = c("DLT", "DLTs")`.  The
#' first element of the vector is used to describe a count of 1.  The second
#' is used in all other cases.
#' @rdname knit_print
#' @export
#' @method knit_print NextBestThreePlusThree
knit_print.NextBestThreePlusThree <- function(
  x,
  ...,
  tox_label = c("toxicity", "toxicities"),
  label = "participant",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)

  # Prepare
  tox_label <- h_prepare_labels(tox_label)
  label <- h_prepare_labels(label)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be chosen using the \"Three ",
    "Plus Three\" rule.\n\n- If no ",
    tox_label[2],
    " have been reported at the current dose level, escalate by one dose level.\n",
    "- If the observed ",
    tox_label[1],
    " rate at the current dose level is exactly 1/3 and no more than three ",
    label[2],
    " treated at the current dose level are evaluable, remain at the current ",
    "dose level.\n",
    "- Otherwise, recommend that the trial stops and identify the MTD as dose ",
    "level immediately below the current one.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestDualEndpoint ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
#' @param biomarker_units (`character`)\cr the units in which the biomarker is
#' measured
#' @rdname knit_print
#' @export
#' @method knit_print NextBestDualEndpoint
knit_print.NextBestDualEndpoint <- function(
  x,
  ...,
  tox_label = "toxicity",
  biomarker_label = "the biomarker",
  biomarker_units = ifelse(x@target_relative, "%", ""),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(biomarker_label, len = 1, any.missing = FALSE)
  assert_character(biomarker_units, len = 1, any.missing = FALSE)

  rv <- paste0(
    "The dose recommended for the next cohort will be chosen in the following ",
    "way.  First, doses that are ineligible according to the increments rule ",
    "will be discarded.  Next, any dose for which the mean posterior probability of ",
    tox_label,
    " being in the overdose range - (",
    x@overdose[1],
    ", ",
    x@overdose[2],
    "] - is ",
    x@max_overdose_prob,
    " or more will also be discarded.  Finally, the dose amongst those remaining ",
    "which has the highest chance that the mean posterior probability that ",
    biomarker_label,
    " is in the target range for ",
    biomarker_label,
    ", which is ",
    x@target[1],
    ifelse(
      x@target_relative,
      "",
      stringr::str_squish(paste0(" ", biomarker_units))
    ),
    " to ",
    x@target[2],
    ifelse(
      x@target_relative,
      "",
      stringr::str_squish(paste0(" ", biomarker_units))
    ),
    " (inclusive),",
    ifelse(
      x@target_relative,
      paste0(" of the maximum ", biomarker_label, " value"),
      ""
    ),
    " will be selected, provided that this probability exceeds ",
    x@target_thresh,
    ".  If no dose meets this threshold, then the highest eligible dose will ",
    "be selected.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestMinDist ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMinDist
knit_print.NextBestMinDist <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is both ",
    "eligible and which has the smallest absolute difference between ",
    "its mean posterior estimate of the probability of ",
    tox_label,
    " and the target ",
    tox_label,
    " rate [",
    x@target,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestInfTheory ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param citation_text (`character`)\cr the text used to cite Mozgunov & Jaki
#' @param citation_link (`character`)\cr the link to Mozgunov & Jaki
#' @section Usage Notes:
#' To use a BibTeX-style citation, specify (for example) `citation_text =
#' "@MOZGUNOV", citation_link = ""`.
#' @rdname knit_print
#' @export
#' @method knit_print NextBestInfTheory
knit_print.NextBestInfTheory <- function(
  x,
  ...,
  tox_label = "toxicity",
  citation_text = "Mozgunov & Jaki (2019)",
  citation_link = "https://doi.org/10.1002/sim.8450",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(citation_text, len = 1, any.missing = FALSE)
  assert_character(citation_link, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The recommended dose for the next cohort will be chosen using the ",
    "complex infinite bounds penalisation (CIBP) criterion of ",
    "[",
    citation_text,
    "]",
    ifelse(nchar(citation_link) > 0, paste0("(", citation_link, ")"), ""),
    ".  Let\n\n",
    "$$ \\delta(\\hat{p}_d, \\gamma) = \\frac{(\\hat{p}_d - \\gamma)^2}",
    "{\\hat{p}_d^a \\cdot (1 - \\hat{p}_d)^{2 - a}} $$\n\n",
    "where a is the non-centrality parameter with a value of ",
    x@asymmetry,
    ", &gamma; is the target ",
    tox_label,
    " rate with a value of ",
    x@target,
    " and $\\hat{p}_d$ is the mean posterior estimate of the probability of ",
    tox_label,
    " at dose level d.\n\n",
    "The recommended dose for the next cohort will be ",
    "the value of d that minimises $\\delta(\\hat{p}_d, \\gamma)$.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestTD ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestTD
knit_print.NextBestTD <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is both ",
    "eligible and which is the highest dose in the dose grid strictly less than ",
    "the dose (which may not be in the dose grid) that has a posterior plug-in ",
    "estimate of the probability of ",
    tox_label,
    " exactly equal to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestMaxGain ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMaxGain
knit_print.NextBestMaxGain <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is closest to ",
    "Gstar, the dose that maximises the gain for probability of ",
    tox_label,
    " exactly equal to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestProbMTDLTE ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestProbMTDLTE
knit_print.NextBestProbMTDLTE <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the dose level with ",
    "the highest probability of being the highest dose with an estimated ",
    "probability of ",
    tox_label,
    " less than or equal to ",
    x@target,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestProbMTDMinDist ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestProbMTDMinDist
knit_print.NextBestProbMTDMinDist <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the dose level with ",
    "the highest probability of being the highest dose with an estimated ",
    "probability of ",
    tox_label,
    " closest to ",
    x@target,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestNCRMLoss ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param format_func (`function`)\cr The function used to format the range table.
#' @importFrom rlang .data
#' @rdname knit_print
#' @export
#' @method knit_print NextBestNCRMLoss
knit_print.NextBestNCRMLoss <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE,
  format_func = h_knit_format_func
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  param <- list(...)
  param[["x"]] <- x %>%
    tidy() %>%
    dplyr::select(-MaxOverdoseProb)
  param[["col.names"]] <- c("Range", "Lower", "Upper", "Loss Coefficient")
  rv <- paste0(
    "The dose recommended for the next cohort will be chosen in the following ",
    "way:\n\n-  First, the chance that the probability of ",
    tox_label,
    " falls into each of the underdose, target ",
    ifelse(
      any(x@unacceptable != c(1, 1)),
      ", overdose and unacceptable",
      " and overdose"
    ),
    " dose ranges is calculated for element of the dose grid.\n",
    "-  Next, the loss associated with each dose is calculated by multiplying ",
    "these probabilities by the corresponding loss coefficient and summing the result.\n",
    "-  Then ineligible doses, and those with a probability of being in the ",
    ifelse(
      length(x@losses) == 3,
      "overdose range",
      "overdose or unaccaptable ranges"
    ),
    " that is greater than ",
    x@max_overdose_prob,
    ", are discarded.\n",
    "-  Finally, the dose level with the smallest loss is selected as the ",
    "recommended dose for the next cohort.\n\n",
    ifelse(
      toupper(tox_label) == tox_label,
      tox_label,
      stringr::str_to_sentence(tox_label)
    ),
    " ranges and loss coefficients are given in the following table:\n\n",
    paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n"),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestTDsamples ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestTDsamples
knit_print.NextBestTDsamples <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is both ",
    "eligible and which is the highest dose in the dose grid strictly less than ",
    "the dose (which may not be in the dose grid) that has a full Bayes posterior ",
    "estimate of the probability of ",
    tox_label,
    " exactly equal to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}


# NextBestMaxGainSamples ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMaxGainSamples
knit_print.NextBestMaxGainSamples <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is closest to ",
    "Gstar, the dose for which the full Bayes posterior estimate of the probability of ",
    tox_label,
    " maximises the gain relative to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestOrdinal
knit_print.NextBestOrdinal <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(tox_label, max.len = 2, any.missing = FALSE)

  tox_label <- h_prepare_labels(tox_label)
  rv <- paste0(
    "Based on a ",
    tox_label[1],
    " grade of ",
    x@grade,
    ": ",
    paste0(
      knit_print(x@rule, asis = asis, tox_label = tox_label, ...),
      collapse = "\n"
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# Integration with knitr ----
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional utility functions to allow human-friendly rendition of
#' crmPack objects in Markdown and Quarto files.  This file contains methods for
#' all design classes, not just those that are direct descendants of `Design`.
#'
#' @return a character string that represents the object in markdown.
#' @name knit_print
NULL

#' Internal Helper Functions for Validation of [`StartingDose`] Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Validates that the `StartingDose` object contains valid `starting_dose`.
#'
#' @param object (`StartingDose`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
#' @keywords internal
v_starting_dose <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@starting_dose, finite = TRUE, lower = 0),
    "starting_dose must be a non-negative, finite number"
  )
  v$result()
}

# Helper class

#' `StartingDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StartingDose`] is a simple wrapper class for the `startingDose` slot of all
#' design classes. It is used internally by `knit_print` methods
#'
#' @slot starting_dose (`numeric`)\cr the starting dose
#' @rdname StartingDose-class
#' @keywords internal
.StartingDose <- setClass(
  Class = "StartingDose",
  slots = c(
    starting_dose = "numeric"
  ),
  prototype = prototype(
    starting_dose = 1
  ),
  validity = v_starting_dose,
  contains = "CrmPackClass"
)

## constructor ----

#' @rdname StartingDose-class
#' @param starting_dose (`positive_number`)\cr see slot definition.
StartingDose <- function(starting_dose) {
  new(
    "StartingDose",
    starting_dose = starting_dose
  )
}

#' @rdname StartingDose-class
#' @note Typically, end users will not use the `.DefaultStartingDose()` function.
.DefaultStartingDose <- function() {
  StartingDose(starting_dose = 5)
}

# Helper functions ----

h_knit_print_design <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  default_sections = NA,
  user_sections = NA,
  ignore_slots = c(),
  asis = TRUE
) {
  assert_flag(asis)
  # Because subsections use level + 1 and 6 is the lowest markdown header level
  assert_int(level, lower = 1, upper = 5)
  assert_character(title, any.missing = FALSE, len = 1L)

  slots_to_process <- setdiff(slotNames(x), ignore_slots)

  args <- list(...)
  units <- ifelse("units" %in% names(args), paste0(" ", args[["units"]]), "")
  section_labels <- h_prepare_section_labels(
    x,
    default_sections,
    user_sections
  )
  assert_subset(slots_to_process, names(section_labels))

  rv <- paste0(
    h_markdown_header(title, level = level),
    paste0(
      lapply(
        slots_to_process,
        function(nm) {
          tmp <- switch(
            nm,
            starting_dose = knit_print(
              StartingDose(x@starting_dose),
              asis = FALSE,
              level = level + 1L,
              ...
            ),
            startingDose = knit_print(
              StartingDose(x@startingDose),
              asis = FALSE,
              level = level + 1L,
              ...
            ),
            pl_cohort_size = ifelse(
              identical(slot(x, "pl_cohort_size"), CohortSizeConst(0)),
              "Placebo will not be administered in the trial.\n\n",
              knit_print(
                slot(x, "pl_cohort_size"),
                asis = FALSE,
                level = level + 1L,
                ...
              )
            ),
            {
              knit_print(slot(x, nm), asis = FALSE, level = level + 1L, ...)
            }
          )
          paste0(h_markdown_header(section_labels[nm], level + 1L), tmp)
        }
      ),
      collapse = "\n\n"
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @description A Helper Function to create Markdown Headers
#'
#' @param text (`character`) the header text
#' @param level (`positive_integer`) the level of the header.  Must be between 1 and 6.
#' @return the Markdown header string: a newline, `#` repeated `level` times,
#' a space, `text` followed by two newlines.
#' @keywords internal
#' @noRd
h_markdown_header <- function(text, level = 2L) {
  assert_character(text, any.missing = FALSE, len = 1L, min.chars = 2L)
  assert_int(level, lower = 1, upper = 6)

  paste0(
    "\n",
    stringr::str_dup("#", level),
    " ",
    text,
    "\n\n"
  )
}

#' Modify a Set of Default Slot Labels With Custom Custom Labels
#'
#' x (`S4`)\cr the S4 object for which slot labels are required
#' default_labels (`character`)\cr a vector of slot labels whose names are a
#' superset of the slot names of `x`
#' user_labels (`character`)\cr a vector of slot labels whose names are a
#' superset of the slot names of `x`.  Can be `NA`, in which case no updates
#' are made
#' @returns `default_labels` updated according to `user_labels`
#' @noRd
#' @keywords internal
h_prepare_section_labels <- function(x, default_labels, user_labels = NA) {
  assert_true(isS4(x))
  assert_character(default_labels, any.missing = FALSE)

  if (!any(is.na(user_labels))) {
    assert_character(user_labels, any.missing = FALSE)
    assert_subset(names(user_labels), slotNames(x))

    for (nm in names(user_labels)) {
      default_labels[nm] <- user_labels[nm]
    }
  }
  default_labels
}

# Methods ----

# StartingDose ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print StartingDose
knit_print.StartingDose <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  args <- list(...)
  units <- ifelse("units" %in% names(args), paste0(" ", args[["units"]]), "")
  rv <- paste0(
    "The starting dose is ",
    paste0(x@starting_dose, units),
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# RuleDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param level (`positive_integer`) The level of the headings used to separate
#' slots.  Must be between 1 and 6.
#' @param title (`character`) The text of the heading of the section describing
#' the design
#' @param sections (`character`) a named vector of length at least 4 defining
#' the headings used to define the sections corresponding to the design's slots.
#' The element names must match the Design's slot names.
#' @rdname knit_print
#' @export
#' @method knit_print RuleDesign
knit_print.RuleDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose"
    ),
    user_sections = sections,
    asis = asis
  )
}

# Design ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print Design
knit_print.Design <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose toxicity model",
      "pl_cohort_size" = "Use of placebo"
    ),
    user_sections = sections,
    asis = asis
  )
}

# DualDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DualDesign
knit_print.DualDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(title, len = 1, any.missing = FALSE)
  assert_integer(level, len = 1, lower = 1, upper = 6)

  args <- list(...)
  bLabel <- ifelse(
    "biomarker_label" %in% names(args),
    args[["biomarker_label"]],
    "biomarker"
  )
  tLabel <- ifelse(
    "tox_label" %in% names(args),
    args[["tox_label"]],
    "toxicity"
  )

  if (is.na(sections)) {
    sections <- c(
      "model" = paste0("Dose-", tLabel, " and dose-", bLabel, " models")
    )
  } else {
    if (!("model" %in% names(sections))) {
      sections["model"] <- paste0(
        "Dose-",
        tLabel,
        " and dose-",
        bLabel,
        " models"
      )
    }
  }

  knit_print.Design(
    x,
    level = level,
    title = title,
    sections = sections,
    asis = asis,
    ...
  )
}

# DADesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DADesign
knit_print.DADesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose toxicity model",
      "pl_cohort_size" = "Use of placebo",
      "safetyWindow" = "Safety window"
    ),
    user_sections = sections,
    asis = asis
  )
}

# TDDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print TDDesign
knit_print.TDDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  knit_print.Design(
    x,
    level = level,
    title = title,
    sections = sections,
    asis = asis,
    ...
  )
}

# DualResponsesDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DualResponsesDesign
knit_print.DualResponsesDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  knit_print.Design(
    x,
    level = level,
    title = title,
    sections = sections,
    asis = asis,
    ...
  )
}

# DesignOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DesignOrdinal
knit_print.DesignOrdinal <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "next_best" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "starting_dose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose toxicity model",
      "pl_cohort_size" = "Use of placebo"
    ),
    user_sections = sections,
    asis = asis
  )
}

# DesignGrouped ----

# Needs special handling because of the empty models and nested rules in the
# mono and combo slots and because of the many slots that are of built-in types
# rather than being of crmPack-specific types

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DesignGrouped
knit_print.DesignGrouped <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = c(
    "model" = "Dose toxicity model",
    "mono" = "Monotherapy rules",
    "combo" = "Combination therapy rules",
    "other" = "Other details"
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(title, len = 1, any.missing = FALSE)
  assert_integer(level, len = 1, lower = 1, upper = 6)

  rv <- paste0(
    h_markdown_header(sections["model"], level = level),
    knit_print(x@model, asis = FALSE, ...),
    h_markdown_header(sections["mono"], level = level),
    h_knit_print_design(
      x@mono,
      asis = FALSE,
      level = level + 1L,
      ignore_slots = c("model"),
      default_sections = c(
        "nextBest" = "Dose recommendation",
        "cohort_size" = "Cohort size",
        "data" = "Observed monotherapy data",
        "startingDose" = "Starting dose",
        "increments" = "Escalation rule",
        "stopping" = "Stopping rule",
        "pl_cohort_size" = "Use of placebo"
      ),
      sections = sections[["mono"]],
      ...
    ),
    h_markdown_header(sections["combo"], level = level),
    h_knit_print_design(
      x@combo,
      asis = FALSE,
      level = level + 1L,
      ignore_slots = "model",
      default_sections = c(
        "nextBest" = "Dose recommendation",
        "cohort_size" = "Cohort size",
        "data" = "Observed combination therapy data",
        "startingDose" = "Starting dose",
        "increments" = "Escalation rule",
        "stopping" = "Stopping rule",
        "pl_cohort_size" = "Use of placebo"
      ),
      sections = sections[["combo"]],
      ...
    ),
    h_markdown_header(sections["other"], level = level),
    ifelse(
      x@first_cohort_mono_only,
      paste0(
        "No combination dosing may occur until the results of at least one ",
        "monotherapy cohort are available.\n\n"
      ),
      "Simultaneous combination and monotherapy dosing is permitted from the outset.\n\n"
    ),
    ifelse(
      x@same_dose_for_start,
      paste0(
        "When monotherapy and combination therapy are used in the same cohort ",
        "for the first time, the same dose must be used for both regimens.\n\n"
      ),
      paste0(
        "When monotherapy and combination therapy are used in the same cohort ",
        "for the first time, the use of a different dose in each regimen is permitted.\n\n"
      )
    ),
    ifelse(
      x@same_dose_for_all,
      paste0(
        "Whenever monotherapy and combination therapy are used in the same cohort, ",
        "the same dose must be used for both regimens.\n\n"
      ),
      paste0(
        "Whenever monotherapy and combination therapy are used in the same cohort, ",
        "the use of a different dose in each regimen is permitted.\n\n"
      )
    )
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# TDsamplesDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print TDsamplesDesign
knit_print.TDsamplesDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = level,
    title = title,
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "model" = "Dose toxicity model",
      "stopping" = "Stopping rule",
      "increments" = "Escalation rule",
      "pl_cohort_size" = "Use of placebo"
    ),
    user_sections = sections,
    asis = asis
  )
}

# DualResponsesDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DualResponsesDesign
knit_print.DualResponsesDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = level,
    title = title,
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose-toxicity model",
      "eff_model" = "Dose-efficacy model",
      "pl_cohort_size" = "Use of placebo"
    ),
    ignore_sections = c("model", "eff_model"),
    sections = sections,
    asis = asis
  )
}

# DualResponsesSamplesDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DualResponsesSamplesDesign
knit_print.DualResponsesSamplesDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = level,
    title = title,
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose-toxicity model",
      "eff_model" = "Dose-efficacy model",
      "pl_cohort_size" = "Use of placebo"
    ),
    ignore_sections = c("model", "eff_model"),
    sections = sections,
    asis = asis
  )
}

# RuleDesignOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print RuleDesignOrdinal
knit_print.RuleDesignOrdinal <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "next_best" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "starting_dose" = "Starting dose"
    ),
    user_sections = sections,
    asis = asis
  )
}

##' @include helpers.R
##' @include Model-class.R
NULL

# Helper functions ----

#' Get Starting Values for Quantiles Optimization
#'
#' @param parstart (`numeric` or `NULL`)\cr starting parameter values.
#' @param median (`numeric`)\cr median values.
#' @param dosegrid (`numeric`)\cr dose grid.
#' @param refDose (`number`)\cr reference dose.
#' @param logNormal (`flag`)\cr use log-normal prior?
#'
#' @return Numeric vector of starting values.
#' @keywords internal
h_get_quantiles_start_values <- function(
  parstart,
  median,
  dosegrid,
  refDose,
  logNormal
) {
  if (is.null(parstart)) {
    # Find approximate means for alpha and slope beta from fitting logistic model to medians.
    startAlphaBeta <- coef(lm(I(logit(median)) ~ I(log(dosegrid / refDose))))

    c(
      meanAlpha = unname(startAlphaBeta[1]),
      meanBeta = unname(
        if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2]
      ),
      sdAlpha = 1,
      sdBeta = 1,
      correlation = 0
    )
  } else {
    parstart
  }
}

#' Target Function for Quantiles Optimization
#'
#' @param dosegrid (`numeric`)\cr dose grid.
#' @param refDose (`number`)\cr reference dose.
#' @param lower (`numeric`)\cr lower quantiles.
#' @param median (`numeric`)\cr median quantiles.
#' @param upper (`numeric`)\cr upper quantiles.
#' @param level (`number`)\cr credible level.
#' @param logNormal (`flag`)\cr use log-normal prior?
#' @param seed (`count`)\cr random seed.
#'
#' @return Function that computes target value for optimization.
#' @keywords internal
h_quantiles_target_function <- function(
  dosegrid,
  refDose,
  lower,
  median,
  upper,
  level,
  logNormal,
  seed
) {
  function(param) {
    # Form the mean vector and covariance matrix
    mean <- param[1:2]
    cov <- matrix(
      c(
        param[3]^2,
        prod(param[3:5]),
        prod(param[3:5]),
        param[4]^2
      ),
      nrow = 2L,
      ncol = 2L
    )

    # Simulate from the corresponding normal distribution
    set.seed(seed)
    normalSamples <- mvtnorm::rmvnorm(
      n = 1e4L,
      mean = mean,
      sigma = cov
    )

    # Extract separate coefficients
    alphaSamples <- normalSamples[, 1L]
    betaSamples <- if (logNormal) {
      exp(normalSamples[, 2L])
    } else {
      normalSamples[, 2L]
    }

    # Compute resulting quantiles
    quants <- matrix(
      nrow = length(dosegrid),
      ncol = 3L
    )
    colnames(quants) <- c("lower", "median", "upper")

    # Process each dose
    for (i in seq_along(dosegrid)) {
      # Create samples of the probability
      probSamples <- plogis(
        alphaSamples + betaSamples * log(dosegrid[i] / refDose)
      )

      # Compute lower, median and upper quantile
      quants[i, ] <- quantile(
        probSamples,
        probs = c((1 - level) / 2, 0.5, (1 + level) / 2)
      )
    }

    # Compute the target value
    ret <- max(abs(quants - c(lower, median, upper)))
    structure(ret, mean = mean, cov = cov, quantiles = quants)
  }
}

# Quantiles2LogisticNormal ----

#' Convert Prior Quantiles to Logistic (Log) Normal Model
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function uses generalized simulated annealing to optimize
#' a [`LogisticNormal`] model to be as close as possible
#' to the given prior quantiles.
#'
#' @param dosegrid (`numeric`)\cr the dose grid.
#' @param refDose (`number`)\cr the reference dose.
#' @param lower (`numeric`)\cr the lower quantiles.
#' @param median (`numeric`)\cr the medians.
#' @param upper (`numeric`)\cr the upper quantiles.
#' @param level (`number`)\cr the credible level of the (lower, upper) intervals.
#'   Default is 0.95.
#' @param logNormal (`flag`)\cr use the log-normal prior? If `FALSE` (default),
#'   the normal prior for the logistic regression coefficients is used.
#' @param parstart (`numeric` or `NULL`)\cr starting values for the parameters.
#'   By default, these are determined from the medians supplied.
#' @param parlower (`numeric`)\cr lower bounds on the parameters (intercept alpha
#'   and the slope beta, the corresponding standard deviations and the correlation).
#' @param parupper (`numeric`)\cr upper bounds on the parameters.
#' @param seed (`count`)\cr seed for random number generation.
#' @param verbose (`flag`)\cr should the function be verbose?
#' @param control (`list`)\cr additional options for the optimisation routine,
#'   see [GenSA::GenSA()] for more details.
#'
#' @return A list with the best approximating `model`
#'   ([`LogisticNormal`] or [`LogisticLogNormal`]), the resulting `quantiles`,
#'   the `required` quantiles and the `distance` to the required quantiles,
#'   as well as the final `parameters` (which could be used for running the
#'   algorithm a second time).
#'
#' @importFrom GenSA GenSA
#' @importFrom mvtnorm rmvnorm
#' @export
Quantiles2LogisticNormal <- function(
  dosegrid,
  refDose,
  lower,
  median,
  upper,
  level = 0.95,
  logNormal = FALSE,
  parstart = NULL,
  parlower = c(-10, -10, 0, 0, -0.95),
  parupper = c(10, 10, 10, 10, 0.95),
  seed = 12345,
  verbose = TRUE,
  control = list(
    threshold.stop = 0.01,
    maxit = 50000,
    temperature = 50000,
    max.time = 600
  )
) {
  # Argument validation
  assert_numeric(
    dosegrid,
    min.len = 1,
    any.missing = FALSE,
    sorted = TRUE,
    unique = TRUE
  )
  assert_number(refDose, finite = TRUE)
  assert_numeric(lower, len = length(dosegrid), any.missing = FALSE)
  assert_numeric(
    median,
    len = length(dosegrid),
    any.missing = FALSE,
    sorted = TRUE
  )
  assert_numeric(upper, len = length(dosegrid), any.missing = FALSE)
  assert_probability(level, bounds_closed = FALSE)
  assert_flag(logNormal)
  assert_numeric(parstart, len = 5, null.ok = TRUE)
  assert_numeric(parlower, len = 5, any.missing = FALSE)
  assert_numeric(parupper, len = 5, any.missing = FALSE)
  assert_count(seed, positive = TRUE)
  assert_flag(verbose)
  assert_list(control)

  # Additional validation
  assert_true(all(lower < median))
  assert_true(all(median < upper))
  assert_true(all(parlower < parupper))
  if (!is.null(parstart)) {
    assert_true(all(parlower < parstart))
    assert_true(all(parstart < parupper))
  }

  nDoses <- length(dosegrid)
  control$verbose <- verbose

  startValues <- h_get_quantiles_start_values(
    parstart = parstart,
    median = median,
    dosegrid = dosegrid,
    refDose = refDose,
    logNormal = logNormal
  )

  target <- h_quantiles_target_function(
    dosegrid = dosegrid,
    refDose = refDose,
    lower = lower,
    median = median,
    upper = upper,
    level = level,
    logNormal = logNormal,
    seed = seed
  )

  set.seed(seed)
  # Optimize the target function
  genSAres <- GenSA::GenSA(
    par = startValues,
    fn = target,
    lower = parlower,
    upper = parupper,
    control = control
  )
  distance <- genSAres$value
  pars <- genSAres$par
  targetRes <- target(pars)

  # Construct the model
  model <- if (logNormal) {
    LogisticLogNormal(
      mean = attr(targetRes, "mean"),
      cov = attr(targetRes, "cov"),
      ref_dose = refDose
    )
  } else {
    LogisticNormal(
      mean = attr(targetRes, "mean"),
      cov = attr(targetRes, "cov"),
      ref_dose = refDose
    )
  }

  list(
    model = model,
    parameters = pars,
    quantiles = attr(targetRes, "quantiles"),
    required = cbind(lower, median, upper),
    distance = distance
  )
}

#' Helper for Minimal Informative Unimodal Beta Distribution
#'
#' As defined in \insertCite{NeuenschwanderBransonGsponer2008;textual}{crmPack}, this function
#' computes the parameters of the minimal informative unimodal beta distribution, given the
#' request that the p-quantile should be q, i.e. `X ~ Be(a, b)` with
#' `Pr(X <= q) = p`.
#'
#' @param p (`number`)\cr the probability.
#' @param q (`number`)\cr the quantile.
#' @return A list with the two resulting beta parameters `a` and `b`.
#'
#' @keywords internal
#' @references
#'   \insertAllCited{}
h_get_min_inf_beta <- function(p, q) {
  assert_probability(p, bounds_closed = FALSE)
  assert_probability(q, bounds_closed = FALSE)

  if (q > p) {
    list(
      a = log(p) / log(q),
      b = 1
    )
  } else {
    list(
      a = 1,
      b = log(1 - p) / log(1 - q)
    )
  }
}

# MinimalInformative ----

#' Construct a Minimally Informative Prior
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function constructs a minimally informative prior, which is captured in
#' a [`LogisticNormal`] (or [`LogisticLogNormal`]) object.
#'
#' Based on the proposal by \insertCite{NeuenschwanderBransonGsponer2008;textual}{crmPack},
#' a minimally informative prior distribution is constructed. The
#' required key input is the minimum (\eqn{d_{1}} in the notation of the
#' Appendix A.1 of that paper) and the maximum value (\eqn{d_{J}}) of the dose
#' grid supplied to this function. Then `threshmin` is the probability
#' threshold \eqn{q_{1}}, such that any probability of DLT larger than
#' \eqn{q_{1}} has only 5% probability. Therefore \eqn{q_{1}} is the 95%
#' quantile of the beta distribution and hence \eqn{p_{1} = 0.95}. Likewise,
#' `threshmax` is the probability threshold \eqn{q_{J}}, such that any
#' probability of DLT smaller than \eqn{q_{J}} has only 5% probability
#' (\eqn{p_{J} = 0.05}). The probabilities \eqn{1 - p_{1}} and \eqn{p_{J}} can be
#' controlled with the arguments `probmin` and `probmax`, respectively.
#' Subsequently, for all doses supplied in the
#' `dosegrid` argument, beta distributions are set up from the assumption
#' that the prior medians are linear in log-dose on the logit scale, and
#' [Quantiles2LogisticNormal()] is used to transform the resulting
#' quantiles into an approximating [`LogisticNormal`] (or
#' [`LogisticLogNormal`]) model. Note that the reference dose
#' is not required for these computations.
#'
#' @param dosegrid (`numeric`)\cr the dose grid.
#' @param refDose (`number`)\cr the reference dose.
#' @param threshmin (`number`)\cr any toxicity probability above this threshold
#'   would be very unlikely (see `probmin`) at the minimum dose.
#' @param threshmax (`number`)\cr any toxicity probability below this threshold
#'   would be very unlikely (see `probmax`) at the maximum dose.
#' @param probmin (`number`)\cr the prior probability of exceeding `threshmin`
#'   at the minimum dose.
#' @param probmax (`number`)\cr the prior probability of being below `threshmax`
#'   at the maximum dose.
#' @param ... additional arguments for computations, see
#'   [Quantiles2LogisticNormal()], e.g. `refDose` and
#'   `logNormal=TRUE` to obtain a minimal informative log normal prior.
#'
#' @return See [Quantiles2LogisticNormal()].
#'
#' @example examples/MinimalInformative.R
#' @export
#' @references
#'   \insertAllCited{}
MinimalInformative <- function(
  dosegrid,
  refDose,
  threshmin = 0.2,
  threshmax = 0.3,
  probmin = 0.05,
  probmax = 0.05,
  ...
) {
  # Argument validation
  assert_numeric(
    dosegrid,
    min.len = 1,
    any.missing = FALSE,
    sorted = TRUE,
    unique = TRUE
  )
  assert_number(refDose, finite = TRUE)
  assert_probability(threshmin, bounds_closed = FALSE)
  assert_probability(threshmax, bounds_closed = FALSE)
  assert_probability(probmin, bounds_closed = FALSE)
  assert_probability(probmax, bounds_closed = FALSE)

  nDoses <- length(dosegrid)
  xmin <- dosegrid[1]
  xmax <- dosegrid[nDoses]

  # Derive the beta distributions at the lowest and highest dose
  betaAtMin <- h_get_min_inf_beta(
    q = threshmin,
    p = 1 - probmin
  )
  betaAtMax <- h_get_min_inf_beta(
    q = threshmax,
    p = probmax
  )

  # Get the medians of those beta distributions
  medianMin <- with(betaAtMin, qbeta(p = 0.5, a, b))
  medianMax <- with(betaAtMax, qbeta(p = 0.5, a, b))

  # Determine the medians of all beta distributions
  beta <- (logit(medianMax) - logit(medianMin)) / (log(xmax) - log(xmin))
  alpha <- logit(medianMax) - beta * log(xmax / refDose)
  medianDosegrid <- plogis(alpha + beta * log(dosegrid / refDose))

  # Calculate 95% credible interval bounds (lower and upper) for all doses
  lower <- upper <- dosegrid
  for (i in seq_along(dosegrid)) {
    # Get minimal informative beta distribution
    thisMinBeta <- h_get_min_inf_beta(
      p = 0.5,
      q = medianDosegrid[i]
    )

    # Derive required quantiles
    lower[i] <- with(thisMinBeta, qbeta(p = 0.025, a, b))
    upper[i] <- with(thisMinBeta, qbeta(p = 0.975, a, b))
  }

  # Transform quantiles to LogisticNormal model
  Quantiles2LogisticNormal(
    dosegrid = dosegrid,
    refDose = refDose,
    lower = lower,
    median = medianDosegrid,
    upper = upper,
    level = 0.95,
    ...
  )
}

# nolint end

# for nextBest methods ----

## some specific helpers ----

#' Calculating the Information Theoretic Distance
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which provides the value of the
#' divergence as given by equation in (7) in the reference at
#' https://doi.org/10.1002/sim.8450.
#'
#' @param prob (`numeric`)\cr vector or matrix with probabilities of a DLT occurring.
#' @param target (`number `)\cr single target probability of a DLT.
#' @param asymmetry (`number`)\cr describes the rate of penalization
#'   for overly toxic does, range 0 to 2.
#'
#' @export
#' @examples
#' h_info_theory_dist(c(0.5, 0.2), 0.4, 1.2)
h_info_theory_dist <- function(prob, target, asymmetry) {
  assert_probabilities(prob)
  assert_true(test_vector(prob) || test_matrix(prob))
  assert_number(target, finite = TRUE)
  assert_number(asymmetry, lower = 0, upper = 2)

  ((prob - target)^2) / (((prob^asymmetry) * (1 - prob)^(2 - asymmetry)))
}

#' Credibility Intervals for Max Gain and Target Doses at `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function for [`nextBest-NextBestMaxGain()`] method. It computes a
#' 95% credibility intervals for given target dose and max gain dose.
#' It also returns a ratio of upper and lower bounds of the interval.
#'
#' @param dose_target (`number`)\cr target dose estimate.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param prob_target (`proportion`)\cr target DLT probability.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the dose grid used
#'   is considered as placebo. This is needed to adjust the max gain dose using
#'   efficacy constant value. If the `placebo` was used, then the `model_eff@const`
#'   is added to `dose_mg`.
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#'
#' @references
#'   \insertRef{YeungWhiteheadReignerBeyerDiackJaki2015}{crmPack}
#'
#' @export
#'
h_next_best_mg_ci <- function(
  dose_target,
  dose_mg,
  prob_target,
  placebo,
  model,
  model_eff
) {
  assert_number(dose_target, na.ok = TRUE)
  assert_number(dose_mg, na.ok = TRUE)
  assert_probability(prob_target)
  assert_flag(placebo)
  assert_class(model, "ModelTox")
  assert_class(model_eff, "Effloglog")

  # Find the variance of the log of target dose.
  mat <- matrix(
    c(
      -1 / (model@phi2),
      -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2
    ),
    nrow = 1
  )
  var_dose_target <- as.vector(mat %*% model@Pcov %*% t(mat))

  # 95% credibility interval for target dose.
  ci_dose_target <- exp(
    log(dose_target) + c(-1, 1) * 1.96 * sqrt(var_dose_target)
  )
  cir_dose_target <- ci_dose_target[2] / ci_dose_target[1]

  # Find the variance of the log of dose_mg.
  # First, find the covariance matrix of all the parameters, phi1, phi2, theta1 and theta2
  # given that phi1 and phi2 are independent of theta1 and theta2.
  log_dose_mg <- log(dose_mg + ifelse(placebo, model_eff@const, 0))

  # Find a delta_g matrix for a variance according to Yeung et. al (2015).
  mean_eff_mg <- model_eff@theta1 + model_eff@theta2 * log(log_dose_mg)
  denom <- model@phi2 * mean_eff_mg * (1 + model@phi2 * log_dose_mg)
  dgphi1 <- -(mean_eff_mg * log_dose_mg * model@phi2 - model_eff@theta2) / denom
  dgphi2 <- -(log_dose_mg *
    (mean_eff_mg * (1 + log_dose_mg * model@phi2) - model_eff@theta2)) /
    denom
  dgtheta1 <- -(log_dose_mg * model@phi2) / denom
  dgtheta2_num <- -(exp(model@phi1 + model@phi2 * log_dose_mg) *
    (model@phi2 * log_dose_mg * log(log_dose_mg) - 1) -
    1)
  dgtheta2 <- dgtheta2_num / denom
  delta_g <- matrix(c(dgphi1, dgphi2, dgtheta1, dgtheta2), 4, 1)

  zero_matrix <- matrix(0, 2, 2)
  cov_beta <- cbind(
    rbind(model@Pcov, zero_matrix),
    rbind(zero_matrix, model_eff@Pcov)
  )
  var_log_dose_mg <- as.vector(t(delta_g) %*% cov_beta %*% delta_g)

  # 95% credibility interval for max gain dose.
  ci_mg <- exp(log_dose_mg + c(-1, 1) * 1.96 * sqrt(var_log_dose_mg))
  ci_ratio_mg <- ci_mg[2] / ci_mg[1]

  list(
    ci_dose_target = ci_dose_target,
    ci_ratio_dose_target = cir_dose_target,
    ci_dose_mg = ci_mg,
    ci_ratio_dose_mg = ci_ratio_mg
  )
}

## next best at grid ----

#' Get Closest Grid Doses for a Given Target Doses for `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function that for a given target doses finds the dose in grid that is
#' closest and below the target. There are four different targets in the context
#' of [`nextBest-NextBestMaxGain()`] method: \eqn{min(`dose_mg`, `dose_target_drt`)},
#' `dose_mg`, `dose_target_drt` or `dose_target_eot`.
#'
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param dose_grid (`numeric`)\cr all possible doses.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the `dose_grid`
#'   is considered as placebo.
#'
#' @export
#'
h_next_best_mg_doses_at_grid <- function(
  dose_target_drt,
  dose_target_eot,
  dose_mg,
  dose_grid,
  doselimit,
  placebo
) {
  assert_number(dose_target_drt, na.ok = TRUE)
  assert_number(dose_target_eot, na.ok = TRUE)
  assert_number(dose_mg, na.ok = TRUE)

  doses_eligible <- h_next_best_eligible_doses(dose_grid, doselimit, placebo)

  # h_find_interval assumes that elements in doses_eligible are strictly increasing.
  next_dose_lev <- h_find_interval(
    min(dose_mg, dose_target_drt),
    doses_eligible
  )
  next_dose <- doses_eligible[next_dose_lev]

  next_dose_mg_lev <- h_find_interval(dose_mg, doses_eligible)
  next_dose_mg <- doses_eligible[next_dose_mg_lev]

  next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
  next_dose_drt <- doses_eligible[next_dose_lev_drt]

  next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
  next_dose_eot <- doses_eligible[next_dose_lev_eot]

  next_dose_list <- list(
    next_dose = next_dose,
    next_dose_drt = next_dose_drt,
    next_dose_eot = next_dose_eot,
    next_dose_mg = next_dose_mg
  )
}

## eligible doses ----

#' Get Eligible Doses from the Dose Grid.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function that gets the eligible doses from the dose grid.
#' The eligible doses are the doses which do not exceed a given
#' `doselimit`. For placebo design, if safety allows (i.e. if there is at least
#' one non-placebo dose which does not exceed the dose limit), the placebo dose
#' is then excluded from the eligible doses.
#'
#' @param dose_grid (`numeric`)\cr all possible doses.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the `dose_grid`
#'   is considered as placebo.
#' @param levels (`flag`)\cr if `TRUE` the levels of eligible doses are returned,
#'   otherwise, the doses (default).
#'
#' @return A numeric vector with eligible doses or eligible dose levels if `levels`
#'   flag is `TRUE`.
#'
#' @export
#' @examples
#' dose_grid <- c(0.001, seq(25, 200, 25))
#' h_next_best_eligible_doses(dose_grid, 79, TRUE)
#' h_next_best_eligible_doses(dose_grid, 24, TRUE)
h_next_best_eligible_doses <- function(
  dose_grid,
  doselimit,
  placebo,
  levels = FALSE
) {
  assert_numeric(
    dose_grid,
    finite = TRUE,
    any.missing = FALSE,
    min.len = 1L,
    sorted = TRUE
  )
  assert_number(doselimit)
  assert_flag(placebo)
  assert_flag(levels)

  is_dose_eligible <- dose_grid <= doselimit
  if (placebo && sum(is_dose_eligible) > 1L) {
    is_dose_eligible[1] <- FALSE
  }

  if (levels) {
    is_dose_eligible
  } else {
    dose_grid[is_dose_eligible]
  }
}

## plot ----

#' Building the Plot for `nextBest-NextBestNCRMLoss` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestNCRMLoss()`]
#' method.
#'
#' @param prob_mat (`numeric`)\cr matrix with probabilities of a grid doses
#'   to be in a given interval. If `is_unacceptable_specified` is `TRUE`, there
#'   must be 4 intervals (columns) in `prob_mat`: `underdosing`, `target`,
#'   `excessive`, `unacceptable`. Otherwise, there must be 3 intervals (columns):
#'   `underdosing`, `target`, `overdose`. Number of rows must be equal to number
#'   of doses in a grid.
#' @param posterior_loss (`numeric`)\cr posterior losses.
#' @param max_overdose_prob (`number`)\cr maximum overdose posterior
#'   probability that is allowed.
#' @param dose_grid (`numeric`)\cr dose grid.
#' @param max_eligible_dose_level (`number`)\cr maximum eligible dose level in
#'   the `dose_grid`.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#' @param is_unacceptable_specified (`flag`)\cr is unacceptable interval specified?
#'
#' @export
h_next_best_ncrm_loss_plot <- function(
  prob_mat,
  posterior_loss,
  max_overdose_prob,
  dose_grid,
  max_eligible_dose_level,
  doselimit,
  next_dose,
  is_unacceptable_specified
) {
  assert_numeric(dose_grid, finite = TRUE, any.missing = FALSE, sorted = TRUE)
  n_grid <- length(dose_grid)
  assert_flag(is_unacceptable_specified)
  assert_probabilities(prob_mat)
  assert_matrix(
    prob_mat,
    min.cols = 3,
    max.cols = 4,
    nrows = n_grid,
    col.names = "named"
  )
  if (!is_unacceptable_specified) {
    assert_names(
      colnames(prob_mat),
      permutation.of = c("underdosing", "target", "overdose")
    )
  } else {
    assert_names(
      colnames(prob_mat),
      permutation.of = c("underdosing", "target", "excessive", "unacceptable")
    )
  }
  assert_numeric(
    posterior_loss,
    finite = TRUE,
    any.missing = FALSE,
    len = n_grid
  )
  assert_probability(max_overdose_prob)
  assert_number(max_eligible_dose_level, lower = 0, upper = n_grid)
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  # Build plots, first for the target probability.
  p1 <- ggplot() +
    geom_bar(
      data = data.frame(Dose = dose_grid, y = prob_mat[, "target"] * 100),
      aes(x = .data$Dose, y = .data$y),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2,
      colour = "darkgreen",
      fill = "darkgreen"
    ) +
    ylim(c(0, 100)) +
    ylab(paste("Target probability [%]"))

  if (is.finite(doselimit)) {
    p1 <- p1 +
      geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
  }

  if (max_eligible_dose_level > 0) {
    p1 <- p1 +
      geom_vline(
        xintercept = dose_grid[max_eligible_dose_level],
        lwd = 1.1,
        lty = 2,
        colour = "red"
      )
  }

  p_loss <- ggplot() +
    # For the loss function.
    geom_bar(
      data = data.frame(Dose = dose_grid, y = posterior_loss),
      aes(x = .data$Dose, y = .data$y),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2,
      colour = "darkgreen",
      fill = "darkgreen"
    ) +
    geom_point(
      aes(x = next_dose, y = max(posterior_loss) + 0.2),
      size = 3,
      pch = 25,
      col = "red",
      bg = "red"
    ) +
    ylab(paste("Loss function"))

  if (!is_unacceptable_specified) {
    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "overdose"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(
        yintercept = max_overdose_prob * 100,
        lwd = 1.1,
        lty = 2,
        colour = "black"
      ) +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Combine it all together.
    plots_single <- list(plot1 = p1, plot2 = p2, plot_loss = p_loss)
    plot_joint <- gridExtra::arrangeGrob(p1, p2, p_loss, nrow = 3)
  } else {
    # Plot in case of 4 toxicity intervals. Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "excessive"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      ylim(c(0, 100)) +
      ylab("Excessive probability [%]")

    p3 <- ggplot() +
      geom_bar(
        data = data.frame(
          Dose = dose_grid,
          y = prob_mat[, "unacceptable"] * 100
        ),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      ylim(c(0, 100)) +
      ylab("Unacceptable probability [%]")

    # Combine it all together.
    plots_single <- list(plot1 = p1, plot2 = p2, plot3 = p3, plot_loss = p_loss)
    plot_joint <- gridExtra::arrangeGrob(p1, p2, p3, p_loss, nrow = 4)
  }

  list(plots_single = plots_single, plot_joint = plot_joint)
}

#' Building the Plot for `nextBest-NextBestTDsamples` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestTDsamples()`]
#' method.
#'
#' @param dose_target_drt_samples (`numeric`)\cr vector of in-trial samples.
#' @param dose_target_eot_samples (`numeric`)\cr vector of end-of-trial samples.
#' @param dose_target_drt (`number`)\cr target in-trial estimate.
#' @param dose_target_eot (`number`)\cr target end-of-trial estimate.
#' @param dose_grid_range (`numeric`)\cr range of dose grid.
#' @param nextBest (`NextBestTDsamples`)\cr the rule for the next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#'
#' @export
#'
h_next_best_tdsamples_plot <- function(
  dose_target_drt_samples,
  dose_target_eot_samples,
  dose_target_drt,
  dose_target_eot,
  dose_grid_range,
  nextBest,
  doselimit,
  next_dose
) {
  assert_numeric(dose_target_drt_samples, any.missing = FALSE)
  assert_numeric(dose_target_eot_samples, any.missing = FALSE)
  assert_number(dose_target_drt)
  assert_number(dose_target_eot)
  assert_range(dose_grid_range, finite = TRUE, unique = FALSE)
  assert_class(nextBest, "NextBestTDsamples")
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  lbl1 <- paste("TD", nextBest@prob_target_drt * 100, "Estimate")
  lbl2 <- paste("TD", nextBest@prob_target_eot * 100, "Estimate")
  labels <- data.frame(
    Type = c("during", "end", "Max", "Next"),
    Alpha = c(0.25, 0.25, 1, 1),
    x = c(
      dose_target_drt,
      dose_target_eot,
      min(doselimit, dose_grid_range[2]),
      next_dose
    )
  )
  p <- ggplot(
    data = rbind(
      data.frame(period = "during", TD = dose_target_drt_samples),
      data.frame(period = "end", TD = dose_target_eot_samples)
    ),
    aes(x = .data$TD, colour = .data$period),
  ) +
    geom_density(
      aes(fill = .data$period, colour = .data$period),
      alpha = 0.25,
      bounds = dose_grid_range,
      show.legend = FALSE
    ) +
    geom_vline(data = labels, aes(xintercept = x, colour = Type)) +
    ylab("Posterior density") +
    scale_colour_manual(
      name = NULL,
      values = c(
        "during" = "orange",
        "end" = "violet",
        "Max" = "red",
        "Next" = "blue"
      ),
      labels = c("during" = lbl1, "end" = lbl2, "Max" = "Max", "Next" = "Next")
    ) +
    scale_fill_manual(
      values = c("during" = "orange", "end" = "violet")
    )
}

#' Building the Plot for `nextBest-NextBestTD` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestTD()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param data (`Data`)\cr the data object from which the dose grid will be fetched.
#' @param prob_dlt (`numeric`)\cr DLT probabilities for doses in grid.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#'
#' @export
#'
h_next_best_td_plot <- function(
  prob_target_drt,
  dose_target_drt,
  prob_target_eot,
  dose_target_eot,
  data,
  prob_dlt,
  doselimit,
  next_dose
) {
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_class(data, "Data")
  assert_probabilities(prob_dlt, len = data@nGrid)
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  dosegrid_range <- dose_grid_range(data)

  p <- ggplot(
    data = data.frame(x = data@doseGrid, y = prob_dlt),
    aes(x = .data$x, y = .data$y)
  ) +
    geom_line(colour = "red", linewidth = 1.5) +
    coord_cartesian(xlim = c(0, dosegrid_range[2])) +
    ylim(c(0, 1)) +
    xlab("Dose Levels") +
    ylab("Probability of DLT")
  if (
    h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = TRUE)
  ) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_drt, y = prob_target_drt),
        aes(x = .data$x, y = .data$y),
        colour = "orange",
        shape = 15,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = paste("TD", prob_target_drt * 100, "Estimate"),
        x = dose_target_drt + 1,
        y = prob_target_drt - 0.2,
        size = 5,
        colour = "orange"
      )
  }

  if (
    h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = TRUE)
  ) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_eot, y = prob_target_eot),
        aes(x = .data$x, y = .data$y),
        colour = "violet",
        shape = 16,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = paste("TD", prob_target_eot * 100, "Estimate"),
        x = dose_target_eot + 1,
        y = prob_target_eot - 0.1,
        size = 5,
        colour = "violet"
      )
  }

  maxdoselimit <- min(doselimit, dosegrid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "brown", lwd = 1.1) +
    geom_text(
      data = data.frame(x = maxdoselimit, y = 0),
      aes(x = .data$x, y = .data$y, label = "Max", hjust = +1, vjust = -30),
      angle = 90,
      vjust = 1.5,
      hjust = 0.5,
      colour = "brown",
    ) +
    geom_vline(xintercept = next_dose, colour = "purple", lwd = 1.1) +
    geom_text(
      data = data.frame(x = next_dose, y = 0),
      aes(x = .data$x, y = .data$y, label = "Next", hjust = 0, vjust = -30),
      angle = 90,
      vjust = -0.5,
      hjust = 0.5,
      colour = "purple"
    )
}

#' Building the Plot for `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestMaxGain()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param max_gain (`number`)\cr the maximum gain estimate.
#' @param next_dose (`number`)\cr next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param data (`DataDual`)\cr the data object from which the dose grid will be fetched.
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#'
#' @export
#'
h_next_best_mg_plot <- function(
  prob_target_drt,
  dose_target_drt,
  prob_target_eot,
  dose_target_eot,
  dose_mg,
  max_gain,
  next_dose,
  doselimit,
  data,
  model,
  model_eff
) {
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_number(dose_mg, na.ok = TRUE)
  assert_number(max_gain, na.ok = TRUE)
  assert_number(next_dose, na.ok = TRUE)
  assert_number(doselimit)
  assert_class(data, "Data")
  assert_class(model, "ModelTox")
  assert_class(model_eff, "Effloglog")

  dosegrid_range <- dose_grid_range(data)

  data_plot <- data.frame(
    dose = rep(data@doseGrid, 3),
    y = c(
      prob(dose = data@doseGrid, model = model),
      efficacy(dose = data@doseGrid, model = model_eff),
      gain(dose = data@doseGrid, model_dle = model, model_eff = model_eff)
    ),
    group = c(
      rep("p(DLE)", data@nGrid),
      rep("Expected Efficacy", data@nGrid),
      rep("Gain", data@nGrid)
    )
  )

  p <- ggplot(data = data_plot, aes(x = .data$dose, y = .data$y)) +
    geom_line(aes(group = group, color = group), linewidth = 1.5) +
    ggplot2::scale_colour_manual(
      name = "curves",
      values = c("blue", "green3", "red")
    ) +
    coord_cartesian(xlim = c(0, dosegrid_range[2])) +
    ylim(range(data_plot$y)) +
    xlab("Dose Level") +
    ylab("Values")

  if (
    h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = FALSE)
  ) {
    lab <- paste("TD", prob_target_eot * 100, "Estimate")
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_eot, y = prob_target_eot),
        aes(x = .data$x, y = .data$y),
        colour = "violet",
        shape = 16,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_target_eot - 1,
        y = 0.2,
        size = 5,
        colour = "violet"
      )
  }

  if (h_in_range(dose_mg, range = dosegrid_range, bounds_closed = FALSE)) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_mg, y = max_gain),
        aes(x = .data$x, y = .data$y),
        colour = "green3",
        shape = 17,
        size = 8
      ) +
      annotate(
        "text",
        label = "Max Gain Estimate",
        x = dose_mg,
        y = max_gain - 0.1,
        size = 5,
        colour = "green3"
      )
  }

  if (
    h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = FALSE)
  ) {
    lab <- paste("TD", prob_target_drt * 100, "Estimate")
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_drt, y = prob_target_drt),
        aes(x = .data$x, y = .data$y),
        colour = "orange",
        shape = 15,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_target_drt + 25,
        y = prob_target_drt + 0.01,
        size = 5,
        colour = "orange"
      )
  }

  maxdoselimit <- min(doselimit, dosegrid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "brown", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Max",
      x = maxdoselimit - 2,
      y = max(data_plot$y),
      size = 5,
      angle = 90,
      vjust = -0.5,
      hjust = 0.5,
      colour = "brown"
    ) +
    geom_vline(xintercept = next_dose, colour = "purple", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Next",
      x = next_dose + 1,
      y = max(data_plot$y) - 0.05,
      size = 5,
      angle = 90,
      vjust = 1.5,
      hjust = 0.5,
      color = "purple"
    )
}

#' Building the Plot for `nextBest-NextBestMaxGainSamples` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestMaxGainSamples()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param dose_mg_samples (`numeric`)\cr for every sample, the dose (from the dose grid)
#'   that gives the maximum gain value.
#' @param next_dose (`number`)\cr next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param dose_grid_range (`numeric`)\cr dose grid range.
#'
#' @export
#'
h_next_best_mgsamples_plot <- function(
  prob_target_drt,
  dose_target_drt,
  prob_target_eot,
  dose_target_eot,
  dose_mg,
  dose_mg_samples,
  next_dose,
  doselimit,
  dose_grid_range
) {
  assert_range(dose_grid_range, finite = TRUE, unique = FALSE)
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_number(dose_mg, na.ok = TRUE)
  assert_numeric(
    dose_mg_samples,
    lower = dose_grid_range[1],
    upper = dose_grid_range[2],
    finite = TRUE,
    any.missing = FALSE
  )
  assert_number(next_dose, na.ok = TRUE)
  assert_number(doselimit)

  p <- ggplot() +
    geom_histogram(
      data = data.frame(Gstar = dose_mg_samples),
      aes(x = .data$Gstar),
      fill = "darkgreen",
      colour = "green3",
      binwidth = 25
    ) +
    coord_cartesian(xlim = c(0, dose_grid_range[2])) +
    ylab("Posterior density")

  if (
    h_in_range(dose_target_drt, range = dose_grid_range, bounds_closed = FALSE)
  ) {
    lab <- paste("TD", prob_target_drt * 100, "Estimate")
    p <- p +
      geom_vline(xintercept = dose_target_drt, colour = "orange", lwd = 1.1) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_target_drt,
        y = 0,
        hjust = -0.1,
        vjust = -20,
        size = 5,
        colour = "orange"
      )
  }

  if (
    h_in_range(dose_target_eot, range = dose_grid_range, bounds_closed = FALSE)
  ) {
    lab <- paste("TD", prob_target_eot * 100, "Estimate")
    p <- p +
      geom_vline(xintercept = dose_target_eot, colour = "violet", lwd = 1.1) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_target_eot,
        y = 0,
        hjust = -0.1,
        vjust = -25,
        size = 5,
        colour = "violet"
      )
  }

  if (h_in_range(dose_mg, range = dose_grid_range, bounds_closed = FALSE)) {
    lab <- "Gstar Estimate"
    p <- p +
      geom_vline(xintercept = dose_mg, colour = "green", lwd = 1.1) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_mg,
        y = 0,
        hjust = -0.1,
        vjust = -25,
        size = 5,
        colour = "green"
      )
  }

  maxdoselimit <- min(doselimit, dose_grid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "red", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Max",
      x = maxdoselimit,
      y = 0,
      hjust = +1,
      vjust = -35,
      colour = "red"
    ) +
    geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Next",
      x = next_dose,
      y = 0,
      hjust = 0.1,
      vjust = -30,
      colour = "blue"
    )
}

#' @include helpers_data.R

# plot ----

## Data ----

#' Plot Method for the [`Data`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`Data`] object.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-Data
#' @rdname plot-Data
#' @export
#' @example examples/Data-method-plot.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "Data", y = "missing"),
  definition = function(x, y, blind = FALSE, legend = TRUE, ...) {
    assert_flag(blind)
    assert_flag(legend)
    h_plot_data_dataordinal(x, blind, legend, ...)
  }
)

#' Plot Method for the [`DataOrdinal`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that creates a plot for [`DataOrdinal`] object.
#'
#' @param x (`DataOrdinal`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param legend (`flag`)\cr whether the legend should be added.
#' @param tox_labels (`named list of character`)\cr the labels of the toxicity
#' categories.
#' @param tox_shapes (`names list of integers`)\cr the symbols used to identify
#' the toxicity categories.
#' @param ... not used.
#'
#' @note With more than 9 toxicity categories, toxicity symbols must be
#' specified manually.\cr With more than 5 toxicity categories, toxicity labels
#' must be specified manually.
#'
#' @return The [`ggplot2`] object.
#'
#' @rdname plot-Data
#' @export
#' @example examples/DataOrdinal-method-plot.R
setMethod(
  f = "plot",
  signature = signature(x = "DataOrdinal", y = "missing"),
  definition = function(
    x,
    y,
    blind = FALSE,
    legend = TRUE,
    tox_labels = NULL,
    tox_shapes = NULL,
    ...
  ) {
    if (is.null(tox_shapes)) {
      assert_true(length(x@yCategories) <= 9)
      tox_shapes <- c(17L, 16L, 15L, 18L, 0L:2L, 5L, 6L)[seq_along(
        x@yCategories
      )]
      names(tox_shapes) <- names(x@yCategories)
    }
    if (is.null(tox_labels)) {
      assert_true(length(x@yCategories) <= 5)
      tox_labels <- switch(
        length(x@yCategories),
        c("black"),
        c("black", "red"),
        c("black", "orange", "red"),
        c("black", "green", "orange", "red"),
        c("black", "green", "yellow", "orange", "red")
      )
      names(tox_labels) <- names(x@yCategories)
    }
    h_plot_data_dataordinal(
      x,
      blind,
      legend,
      tox_labels = tox_labels,
      tox_shapes = tox_shapes,
      ...
    )
  }
)

## DataDual ----

#' Plot Method for the [`DataDual`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`DataDual`] object.
#'
#' @param x (`DataDual`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param ... passed to the first inherited method `plot` after this current
#'   method.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-DataDual
#' @export
#' @example examples/Data-method-plot-DataDual.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "DataDual", y = "missing"),
  definition = function(x, y, blind = FALSE, ...) {
    assert_flag(blind)

    # Call the superclass method, to get the first plot.
    plot1 <- callNextMethod(x, blind = blind, legend = FALSE, ...)

    # Create the second, biomarker plot.
    df <- h_plot_data_df(x, blind, biomarker = x@w)

    plot2 <- ggplot(df, aes(x = dose, y = biomarker)) +
      geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
      scale_colour_manual(
        name = "Toxicity",
        values = c(Yes = "red", No = "black")
      ) +
      scale_shape_manual(name = "Toxicity", values = c(Yes = 17, No = 16)) +
      xlab("Dose Level") +
      ylab("Biomarker")

    if (!blind) {
      plot2 <- plot2 +
        geom_text(
          aes(
            y = biomarker + 0.02 * diff(range(biomarker)),
            label = patient,
            size = 2
          ),
          data = df,
          hjust = 0,
          vjust = 0.5,
          angle = 90,
          colour = "black",
          show.legend = FALSE
        )
    }

    # Arrange both plots side by side.
    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)

## DataDA ----

#' Plot Method for the [`DataDA`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`DataDA`] object.
#'
#' @param x (`DataDA`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param ... passed to the first inherited method `plot` after this current
#'   method.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-DataDA
#' @export
#' @example examples/Data-method-plot-DataDA.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "DataDA", y = "missing"),
  definition = function(x, y, blind = FALSE, ...) {
    assert_flag(blind)

    # Call the superclass method, to get the first plot.
    plot1 <- callNextMethod(x, blind = blind, legend = FALSE, ...)

    # Prepare data set for the second, time plot.
    df <- h_plot_data_df(x, blind, u = x@u, t0 = x@t0)
    df$censored <- ifelse(df$u < x@Tmax & df$toxicity == 0, 1, 0)
    df$tend <- df$t0 + df$u # `tend` stands for `time end`
    df$t0_case <- "Start"
    df$tend_case <- ifelse(
      df$toxicity == "Yes",
      "Yes",
      ifelse(df$censored, "Censored", "No")
    )

    # Build plot object.
    plot2 <- ggplot(df, aes(x = t0, y = patient)) +
      geom_segment(aes(xend = tend, yend = patient)) +
      geom_point(aes(shape = t0_case, colour = t0_case), size = 3) +
      geom_point(
        aes(x = tend, shape = tend_case, colour = tend_case),
        size = 3
      ) +
      scale_colour_manual(
        name = "Toxicity",
        values = c(
          Yes = "red",
          No = "black",
          Start = "black",
          Censored = "black"
        )
      ) +
      scale_shape_manual(
        name = "Toxicity",
        values = c(Yes = 17, No = 16, Start = 1, Censored = 4)
      ) +
      scale_y_continuous(breaks = df$patient, minor_breaks = NULL) +
      xlab("Time") +
      ylab("Patient")

    plot2 <- plot2 +
      h_plot_data_cohort_lines(df$cohort, placebo = x@placebo, vertical = FALSE)

    if (!blind) {
      plot2 <- plot2 +
        geom_text(
          aes(label = ID, size = 2),
          size = 3,
          hjust = 1.5,
          vjust = 0,
          angle = 0,
          colour = "black",
          show.legend = FALSE
        )
    }

    # Arrange both plots side by side.
    gridExtra::arrangeGrob(plot1, plot2, ncol = 1)
  }
)

# update ----

## Data ----

#' Updating `Data` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`Data`] object with new data.
#'
#' @param object (`Data`)\cr object you want to update.
#' @param x (`number`)\cr the dose level (one level only!).
#' @param y (`integer`)\cr the DLT vector (0/1 vector) for all patients in this
#'   cohort. You can also supply `numeric` vectors, but these will then be
#'   converted to `integer` internally.
#' @param ID (`integer`)\cr the patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
#'   to a new cohort.
#' @param check (`flag`)\cr whether the validation of the updated object should
#'   be conducted. See details below.
#' @param ... not used.
#'
#' @return The new, updated [`Data`] object.
#'
#' @details The current implementation of this `update` method allows for
#'   updating the `Data` class object by adding a single dose level `x` only.
#'   However, there might be some use cases where the new cohort to be added
#'   contains a placebo and active dose. Hence, such update would need to be
#'   performed iteratively by calling the `update` method twice. For example,
#'   in the first call a user can add a placebo, and then in the second call,
#'   an active dose. Since having a cohort with placebo only is not allowed,
#'   the `update` method would normally throw the error when attempting to add
#'   a placebo in the first call. To allow for such updates, the `check`
#'   parameter should be then set to `FALSE` for that first call.
#'
#' @aliases update-Data
#' @export
#' @example examples/Data-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(object = "Data"),
  definition = function(
    object,
    x,
    y,
    ID = length(object@ID) + seq_along(y),
    new_cohort = TRUE,
    check = TRUE,
    ...
  ) {
    assert_numeric(x, min.len = 0, max.len = 1)
    assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
    assert_integerish(ID, len = length(y), any.missing = FALSE)
    assert_disjunct(object@ID, ID)
    assert_flag(new_cohort)
    assert_flag(check)

    # How many additional patients, ie. the length of the update.
    n <- length(y)

    # Which grid level is the dose?
    gridLevel <- match_within_tolerance(x, object@doseGrid)
    object@xLevel <- c(object@xLevel, rep(gridLevel, n))

    # Add dose.
    object@x <- c(object@x, rep(as.numeric(x), n))

    # Add DLT data.
    object@y <- c(object@y, as.integer(y))

    # Add ID.
    object@ID <- c(object@ID, as.integer(ID))

    # Add cohort number.
    new_cohort_id <- if (object@nObs == 0) {
      1L
    } else {
      tail(object@cohort, 1L) + ifelse(new_cohort, 1L, 0L)
    }
    object@cohort <- c(object@cohort, rep(new_cohort_id, n))

    # Increment sample size.
    object@nObs <- object@nObs + n

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataOrdinal ----

#' Updating `DataOrdinal` Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that updates existing [`DataOrdinal`] object with new data.
#'
#' @param object (`DataOrdinal`)\cr object you want to update.
#' @param x (`number`)\cr the dose level (one level only!).
#' @param y (`integer`)\cr the vector of toxicity grades (0, 1, 2, ...) for all
#' patients in this cohort. You can also supply `numeric` vectors, but these
#' will then be converted to `integer` internally.
#' @param ID (`integer`)\cr the patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
#'   to a new cohort.
#' @param check (`flag`)\cr whether the validation of the updated object should
#'   be conducted. See Details below.
#' @param ... not used.
#'
#' @return The new, updated [`DataOrdinal`] object.
#'
#' @details The current implementation of this `update` method allows for
#'   updating the `DataOrdinal` class object by adding a single dose level `x` only.
#'   However, there might be some use cases where the new cohort to be added
#'   contains a placebo and active dose. Hence, such update would need to be
#'   performed iteratively by calling the `update` method twice. For example,
#'   in the first call a user can add a placebo, and then in the second call,
#'   an active dose. Since having a cohort with placebo only is not allowed,
#'   the `update` method would normally throw the error when attempting to add
#'   a placebo in the first call. To allow for such updates, the `check`
#'   parameter should be then set to `FALSE` for that first call.
#'
#' @aliases update-DataOrdinal
#' @export
#' @example examples/DataOrdinal-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataOrdinal"),
  definition = function(
    object,
    x,
    y,
    ID = length(object@ID) + seq_along(y),
    new_cohort = TRUE,
    check = TRUE,
    ...
  ) {
    assert_numeric(x, min.len = 0, max.len = 1)
    assert_integerish(
      y,
      lower = 0,
      upper = length(object@yCategories) - 1,
      any.missing = FALSE
    )
    assert_integerish(ID, unique = TRUE, any.missing = FALSE, len = length(y))
    assert_disjunct(object@ID, ID)
    assert_flag(new_cohort)
    assert_flag(check)

    # How many additional patients, ie. the length of the update.
    n <- length(y)

    # Which grid level is the dose?
    gridLevel <- match_within_tolerance(x, object@doseGrid)
    object@xLevel <- c(object@xLevel, rep(gridLevel, n))

    # Add dose.
    object@x <- c(object@x, rep(as.numeric(x), n))

    # Add DLT data.
    object@y <- c(object@y, as.integer(y))

    # Add ID.
    object@ID <- c(object@ID, as.integer(ID))

    # Add cohort number.
    new_cohort_id <- if (object@nObs == 0) {
      1L
    } else {
      tail(object@cohort, 1L) + ifelse(new_cohort, 1L, 0L)
    }
    object@cohort <- c(object@cohort, rep(new_cohort_id, n))

    # Increment sample size.
    object@nObs <- object@nObs + n

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataParts ----

#' Updating `DataParts` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataParts`] object with new data.
#'
#' @param object (`DataParts`)\cr object you want to update.
#' @inheritParams update,Data-method
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataParts`] object.
#'
#' @aliases update-DataParts
#' @export
#' @example examples/Data-method-update-DataParts.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataParts"),
  definition = function(object, x, y, ..., check = TRUE) {
    assert_numeric(y)
    assert_flag(check)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(object = object, x = x, y = y, ..., check = FALSE)

    # Update the part information.

    object@part <- c(object@part, rep(object@nextPart, length(y)))

    # Decide which part the next cohort will belong to:
    # only if the `nextPart` was 1, it can potentially be required
    # to change it to 2 (once it is 2, it stays).
    if (object@nextPart == 1L) {
      # If there was a DLT in one of the cohorts,
      # or if the current dose was the highest from part 1.
      if (any(object@y == 1L) || x == max(object@part1Ladder)) {
        # Then this closes part 1 and the next cohort will be from part 2.
        object@nextPart <- 2L
      }
    }

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataDual ----

#' Updating `DataDual` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataDual`] object with new data.
#'
#' @param object (`DataDual`)\cr object you want to update.
#' @param w (`numeric`)\cr the continuous vector of biomarker values
#'   for all the patients in this update.
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataDual`] object.
#'
#' @aliases update-DataDual
#' @export
#' @example examples/Data-method-update-DataDual.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataDual"),
  definition = function(object, w, ..., check = TRUE) {
    assert_numeric(w)
    assert_flag(check)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(object = object, ..., check = FALSE)

    # Update the biomarker information.
    object@w <- c(object@w, w)

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataDA ----

#' Updating `DataDA` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataDA`] object with new data.
#'
#' @note This function is capable of not only adding new patients but also
#'   updates existing ones with respect to `y`, `t0`, `u` slots.
#'
#' @param object (`DataDA`)\cr object you want to update.
#' @param u (`numeric`)\cr the new DLT free survival times for all patients,
#'   i.e. for existing patients in the `object` as well as for new patients.
#' @param t0 (`numeric`)\cr the time that each patient starts DLT observation
#'   window. This parameter covers all patients, i.e. existing patients in the
#'   `object` as well as for new patients.
#' @param trialtime (`number`)\cr current time in the trial, i.e. a followup
#'   time.
#' @param y (`numeric`)\cr the new DLTs for all patients, i.e. for existing
#'   patients in the `object` as well as for new patients.
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#'   These are used when there are new patients to be added to the cohort.
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataDA`] object.
#'
#' @aliases update-DataDA
#' @export
#' @example examples/Data-method-update-DataDA.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataDA"),
  definition = function(object, u, t0, trialtime, y, ..., check = TRUE) {
    assert_flag(check)
    assert_numeric(y, lower = 0, upper = 1)
    assert_true(length(y) == 0 || length(y) >= object@nObs)
    assert_numeric(u, lower = 0, len = length(y))
    assert_numeric(t0, lower = 0, len = length(y))
    assert_integerish(y * (trialtime >= t0 + u))
    if (length(y) > 0) {
      assert_number(trialtime, lower = max(c(object@t0, t0)))
    }

    # How many additional patients.
    n <- max(length(y) - object@nObs, 0L)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(
      object = object,
      y = y[object@nObs + seq_len(n)], # Empty vector when n = 0.
      ...,
      check = FALSE
    )

    # DLT will be observed once the followup time >= the time to DLT
    # and y = 1 at the same time.
    object@y <- as.integer(y * (trialtime >= t0 + u))

    # Update DLT free survival time.
    object@u <- apply(rbind(u, trialtime - t0), 2, min)

    # Update t0.
    object@t0 <- t0

    if (check) {
      validObject(object)
    }

    object
  }
)

# getEff ----

## generic ----

#' Extracting Efficacy Responses for Subjects Categorized by the DLT
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that extracts efficacy responses for subjects and categorizes it
#' with respect to DLT, i.e. DLT or no DLT. The efficacy responses
#' are reported together with their corresponding dose levels.
#'
#' @param object (`DataDual`)\cr object from which the responses and dose levels
#'   are extracted.
#' @param ... further arguments passed to class-specific methods.
#' @return `list` with efficacy responses categorized by the DLT value.
#' @export
#'
setGeneric(
  name = "getEff",
  def = function(object, ...) {
    standardGeneric("getEff")
  },
  valueClass = "list"
)

## DataDual ----

#' @rdname getEff
#'
#' @param no_dlt (`flag`)\cr should only no DLT responses be returned? Otherwise,
#'   all responses are returned.
#'
#' @aliases getEff-DataDual
#' @example examples/Data-method-getEff.R
#'
setMethod(
  f = "getEff",
  signature = signature(object = "DataDual"),
  definition = function(object, no_dlt = FALSE) {
    assert_flag(no_dlt)

    is_dlt <- object@y == 1L
    is_no_dlt <- !is_dlt

    eff <- if (any(is_no_dlt)) {
      list(x_no_dlt = object@x[is_no_dlt], w_no_dlt = object@w[is_no_dlt])
    } else {
      list(x_no_dlt = NULL, w_no_dlt = NULL)
    }

    if (!no_dlt) {
      eff_dlt <- if (any(is_dlt)) {
        list(x_dlt = object@x[is_dlt], w_dlt = object@w[is_dlt])
      } else {
        list(x_dlt = NULL, w_dlt = NULL)
      }
      eff <- c(eff, eff_dlt)
    }
    eff
  }
)

# ngrid ----

## generic ----

#' Number of Doses in Grid
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that gets the number of doses in grid. User can choose whether
#' the placebo dose (if any) should be counted or not.
#'
#' @param object (`Data`)\cr object with dose grid.
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#' @param ... further arguments passed to class-specific methods.
#' @return `integer` the number of doses in grid.
#' @export
#'
setGeneric(
  name = "ngrid",
  def = function(object, ignore_placebo = TRUE, ...) {
    assert_flag(ignore_placebo)
    standardGeneric("ngrid")
  },
  valueClass = "integer"
)

## Data ----

#' @rdname ngrid
#'
#' @aliases ngrid-Data
#' @example examples/Data-method-ngrid.R
#'
setMethod(
  f = "ngrid",
  signature = signature(object = "Data"),
  definition = function(object, ignore_placebo, ...) {
    if (ignore_placebo && object@placebo) {
      max(object@nGrid - 1L, 0L)
    } else {
      object@nGrid
    }
  }
)

# dose_grid_range ----

## generic ----

#' Getting the Dose Grid Range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that returns a vector of length two with the minimum and maximum
#' dose in a grid. It returns `c(-Inf, Inf)` if the range cannot be determined,
#' which happens when the dose grid is empty. User can choose whether the
#' placebo dose (if any) should be counted or not.
#'
#' @param object (`Data`)\cr object with dose grid.
#' @param ... further arguments passed to class-specific methods.
#' @return A `numeric` vector containing the minimum and maximum of all the
#'   doses in a grid or `c(-Inf, Inf)`.
#'
#' @export
#'
setGeneric(
  name = "dose_grid_range",
  def = function(object, ...) {
    standardGeneric("dose_grid_range")
  },
  valueClass = "numeric"
)

## Data ----

#' @rdname dose_grid_range
#'
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
#' @aliases dose_grid_range-Data
#' @example examples/Data-method-dose_grid_range.R
#'
setMethod(
  f = "dose_grid_range",
  signature = signature(object = "Data"),
  definition = function(object, ignore_placebo = TRUE) {
    h_obtain_dose_grid_range(object, ignore_placebo)
  }
)


## DataOrdinal ----

#' @include Data-methods.R
#' @rdname dose_grid_range
#' @description `r lifecycle::badge("experimental")`
#'
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
#' @aliases dose_grid_range-Data
#' @example examples/DataOrdinal-method-dose_grid_range.R
#'
setMethod(
  f = "dose_grid_range",
  signature = signature(object = "DataOrdinal"),
  definition = function(object, ignore_placebo = TRUE) {
    h_obtain_dose_grid_range(object, ignore_placebo)
  }
)

# tidy ----

## GeneralData ----

#' Tidy Method for the [`GeneralData`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`GeneralData`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-GeneralData
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "GeneralData"),
  definition = function(x, ...) {
    d <- tibble::tibble(
      ID = x@ID,
      Cohort = x@cohort,
      Dose = x@x,
      XLevel = x@xLevel,
      Tox = as.logical(x@y),
      Placebo = x@placebo,
      NObs = x@nObs,
      NGrid = x@nGrid,
      DoseGrid = list(x@doseGrid)
    ) %>%
      h_tidy_class(x)
  }
)

## DataGrouped ----

#' Tidy Method for the [`DataGrouped`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataGrouped`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataGrouped
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataGrouped"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(Group = x@group) %>%
      h_tidy_class(x)
  }
)

## DataDA ----

#' Tidy Method for the [`DataDA`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataDA`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataDA
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataDA"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(U = x@u) %>%
      tibble::add_column(T0 = x@t0) %>%
      tibble::add_column(TMax = x@Tmax) %>%
      h_tidy_class(x)
  }
)

## DataDA ----

#' Tidy Method for the [`DataDual`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataDual`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataDual
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataDual"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(W = x@w) %>%
      h_tidy_class(x)
  }
)

## DataParts ----

#' Tidy Method for the [`DataParts`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataParts`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataParts
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataParts"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(Part = x@part) %>%
      tibble::add_column(NextPart = x@nextPart) %>%
      tibble::add_column(Part1Ladder = list(x@part1Ladder)) %>%
      h_tidy_class(x)
  }
)

## DataMixture ----

#' Tidy Method for the [`DataMixture`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataMixture`] object.
#' @section Usage Notes:
#' The prior observations are indicated by a `Cohort` value of `0` in the returned
#' `tibble`.
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataMixture
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataMixture"),
  definition = function(x, ...) {
    observed <- callNextMethod()
    tibble::tibble(
      Cohort = 0,
      Dose = x@xshare,
      Tox = as.logical(x@yshare),
      ID = sort(seq_along(x@xshare)),
      Placebo = x@placebo,
      NObs = x@nObs,
      NGrid = x@nGrid,
      DoseGrid = list(x@doseGrid),
      XLevel = which(x@doseGrid %in% x@xshare)
    ) %>%
      dplyr::bind_rows(observed) %>%
      h_tidy_class(x)
  }
)


## DataOrdinal ----

#' Tidy Method for the [`DataMixture`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataOrdinal`] object.
#' @section Usage Notes:
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataOrdinal
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataOrdinal"),
  definition = function(x, ...) {
    y <- tibble::tibble(
      ID = x@ID,
      Cohort = x@cohort,
      Dose = x@x,
      Tox = x@y,
      Placebo = x@placebo,
      NObs = x@nObs,
      NGrid = x@nGrid,
      DoseGrid = list(x@doseGrid),
      XLevel = x@xLevel
    ) %>%
      tidyr::pivot_wider(
        names_from = "Tox",
        values_from = "Tox",
        names_prefix = "Cat",
        values_fill = 0
      )
    if (nrow(y) > 0) {
      y <- y %>%
        dplyr::mutate(
          dplyr::across(tidyselect::matches("Cat\\d+"), \(x) x > 0)
        ) %>%
        dplyr::rowwise() %>%
        dplyr::mutate(
          AnyTox = any(dplyr::across(
            c(tidyselect::starts_with("Cat"), -tidyselect::all_of("Cat0")),
            any
          )),
          # Direct assignment fails on GitHub
          Cat0 = !.data$AnyTox
        ) %>%
        dplyr::select(-tidyselect::all_of("AnyTox")) %>%
        dplyr::ungroup()
    }
    y <- y %>% h_tidy_class(x)
    y
  }
)

#' @include Design-validity.R
#' @include Model-class.R
#' @include Rules-class.R
#' @include Data-class.R
#' @include helpers.R
#' @include CrmPackClass-class.R
NULL

# RuleDesign ----

## class ----

#' `RuleDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`RuleDesign`] is the class for rule-based designs. The difference between
#' this class and the [`Design`] class is that [`RuleDesign`] does not contain
#' `model`, `stopping` and `increments` slots.
#'
#' @slot nextBest (`NextBest`)\cr how to find the next best dose.
#' @slot cohort_size (`CohortSize`)\cr rules for the cohort sizes.
#' @slot data (`Data`)\cr specifies dose grid, any previous data, etc.
#' @slot startingDose (`number`)\cr the starting dose, it must lie on the dose
#'   grid in `data`.
#'
#' @aliases RuleDesign
#' @export
#'
.RuleDesign <- setClass(
  Class = "RuleDesign",
  slots = c(
    nextBest = "NextBest",
    cohort_size = "CohortSize",
    data = "Data",
    startingDose = "numeric"
  ),
  prototype = prototype(
    nextBest = .NextBestThreePlusThree(),
    cohort_size = CohortSizeConst(3),
    data = Data(doseGrid = 1:3),
    startingDose = 1
  ),
  contains = "CrmPackClass",
  validity = v_rule_design
)

## constructor ----

#' @rdname RuleDesign-class
#'
#' @param nextBest (`NextBest`)\cr see slot definition.
#' @param cohort_size (`CohortSize`)\cr see slot definition.
#' @param data (`Data`)\cr see slot definition.
#' @param startingDose (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Design-class-RuleDesign.R
#'
RuleDesign <- function(nextBest, cohort_size, data, startingDose) {
  new(
    "RuleDesign",
    nextBest = nextBest,
    cohort_size = cohort_size,
    data = data,
    startingDose = as.numeric(startingDose)
  )
}

#' @rdname RuleDesign-class
#' @note Typically, end users will not use the `.DefaultRuleDesign()` function.
#' @export

.DefaultRuleDesign <- function() {
  RuleDesign(
    nextBest = NextBestThreePlusThree(),
    cohort_size = CohortSizeConst(size = 3L),
    data = Data(doseGrid = c(5, 10, 15, 25, 35, 50, 80)),
    startingDose = 5
  )
}

## ThreePlusThreeDesign ----

#' @describeIn RuleDesign-class creates a new 3+3 design object from a dose grid.
#'
#' @param doseGrid (`numeric`)\cr the dose grid to be used (sorted).
#'
#' @export
#' @example examples/Design-class-ThreePlusThreeDesign.R
#'
ThreePlusThreeDesign <- function(doseGrid) {
  empty_data <- Data(doseGrid = doseGrid)

  # Using a constant cohort size of 3 we obtain exactly the 3+3 design.
  RuleDesign(
    nextBest = NextBestThreePlusThree(),
    data = empty_data,
    cohort_size = CohortSizeConst(size = 3L),
    startingDose = doseGrid[1]
  )
}

# Design ----

## class ----

#' `Design`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Design`] is the class for rule-based designs. The difference between
#' this class and its parent [`RuleDesign`] class is that [`Design`] class
#' contains additional `model`, `stopping` and `increments` slots.
#'
#' @slot model (`GeneralModel`)\cr the model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases Design
#' @export
#'
.Design <- setClass(
  Class = "Design",
  slots = c(
    model = "GeneralModel",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticNormal(),
    nextBest = .NextBestNCRM(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname Design-class
#'
#' @param model (`GeneralModel`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-Design.R
#'
#'
Design <- function(
  model,
  stopping,
  increments,
  pl_cohort_size = CohortSizeConst(0L),
  ...
) {
  start <- RuleDesign(...)
  new(
    "Design",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname Design-class
#' @note Typically, end users will not use the `.DefaultDesign()` function.
#' @export
.DefaultDesign <- function() {
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
  my_stopping2 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  my_stopping3 <- StoppingMinPatients(nPatients = 20)
  my_stopping <- (my_stopping1 & my_stopping2) | my_stopping3

  # Initialize the design.
  design <- Design(
    model = LogisticLogNormal(
      mean = c(-0.85, 1),
      cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
      ref_dose = 56
    ),
    nextBest = NextBestNCRM(
      target = c(0.2, 0.35),
      overdose = c(0.35, 1),
      max_overdose_prob = 0.25
    ),
    stopping = my_stopping,
    increments = IncrementsRelative(
      intervals = c(0, 20),
      increments = c(1, 0.33)
    ),
    cohort_size = my_size,
    data = Data(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100)),
    startingDose = 3
  )
}

# DualDesign ----

## class ----

#' `DualDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DualDesign`] is the class for the dual-endpoint CRM design. This class has
#' special requirements for the `model` and `data` slots in comparison to the
#' parent class [`Design`].
#'
#' @note the `nextBest` slot can be of any class, this allows for easy comparison
#'   with recommendation methods that don't use the biomarker information.
#'
#' @slot model (`DualEndpoint`)\cr the model to be used.
#' @slot data (`DataDual`)\cr specifies dose grid, any previous data, etc.
#'
#' @aliases DualDesign
#' @export
#'
.DualDesign <- setClass(
  Class = "DualDesign",
  slots = c(
    model = "DualEndpoint",
    data = "DataDual"
  ),
  prototype = prototype(
    model = .DualEndpoint(),
    nextBest = .NextBestDualEndpoint(),
    data = DataDual(doseGrid = 1:2),
    startingDose = 1
  ),
  contains = "Design"
)

## constructor ----

#' @rdname DualDesign-class
#'
#' @param model (`DualEndpoint`)\cr see slot definition.
#' @param data (`DataDual`)\cr see slot definition.
#' @inheritDotParams Design
#'
#' @export
#' @example examples/Design-class-DualDesign.R
#'
DualDesign <- function(model, data, ...) {
  start <- Design(model = model, data = data, ...)
  new(
    "DualDesign",
    start,
    model = model,
    data = data
  )
}

## default constructor ----

#' @rdname DualDesign-class
#' @note Typically, end users will not use the `.DefaultDualDesign()` function.
#' @export
.DefaultDualDesign <- function() {
  my_model <- DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2betaW = 0.01,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    rw1 = TRUE
  )

  # Choose the rule for selecting the next dose.
  my_next_best <- NextBestDualEndpoint(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  # Choose the rule for the cohort-size.
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  # Choose the rule for stopping.
  my_stopping1 <- StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5
  )
  my_stopping <- my_stopping1 | StoppingMinPatients(40)

  # Choose the rule for dose increments.
  my_increments <- IncrementsRelative(
    intervals = c(0, 20),
    increments = c(1, 0.33)
  )

  # Initialize the design.
  DualDesign(
    model = my_model,
    data = DataDual(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100)),
    nextBest = my_next_best,
    stopping = my_stopping,
    increments = my_increments,
    cohort_size = my_size,
    startingDose = 3
  )
}

# TDsamplesDesign ----

## class ----

#' `TDsamplesDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TDsamplesDesign`] is the class of design based only on DLT responses using
#' [`ModelTox`] class model (i.e. [`LogisticIndepBeta`]) as well as MCMC samples
#' obtained for this model.
#'
#' @slot model (`ModelTox`)\cr the pseudo DLT model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases TDsamplesDesign
#' @export
#'
.TDsamplesDesign <- setClass(
  Class = "TDsamplesDesign",
  slots = c(
    model = "ModelTox",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticIndepBeta(),
    nextBest = .NextBestTDsamples(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname TDsamplesDesign-class
#'
#' @param model (`ModelTox`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-TDsamplesDesign.R
#'
TDsamplesDesign <- function(
  model,
  stopping,
  increments,
  pl_cohort_size = CohortSizeConst(0L),
  ...
) {
  start <- RuleDesign(...)
  new(
    "TDsamplesDesign",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname TDsamplesDesign-class
#' @note Typically, end users will not use the `.DefaultTDsamplesDesign()` function.
#' @export
.DefaultTDsamplesDesign <- function() {
  empty_data <- Data(doseGrid = seq(25, 300, 25))

  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )

  TDsamplesDesign(
    model = my_model,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = range(empty_data@doseGrid),
      increments = c(2, 2)
    ),
    nextBest = NextBestTDsamples(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3,
      derive = function(samples) {
        as.numeric(quantile(samples, probs = 0.3))
      }
    ),
    cohort_size = CohortSizeConst(size = 3),
    data = empty_data,
    startingDose = 25
  )
}

# TDDesign ----

## class ----

#' `TDDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TDDesign`] is the class of design based only on DLT responses using
#' [`ModelTox`] class model (i.e. [`LogisticIndepBeta`]) without MCMC samples.
#'
#' @slot model (`ModelTox`)\cr the pseudo DLT model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases TDDesign
#' @export
#'
.TDDesign <- setClass(
  Class = "TDDesign",
  slots = c(
    model = "ModelTox",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticIndepBeta(),
    nextBest = .NextBestTD(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname TDDesign-class
#'
#' @param model (`ModelTox`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-TDDesign.R
#'
TDDesign <- function(
  model,
  stopping,
  increments,
  pl_cohort_size = CohortSizeConst(0L),
  ...
) {
  start <- RuleDesign(...)
  new(
    "TDDesign",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname TDDesign-class
#' @note Typically, end users will not use the `.DefaultTDDesign()` function.
#' @export
.DefaultTDDesign <- function() {
  empty_data <- Data(doseGrid = seq(25, 300, 25))

  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )

  TDDesign(
    model = my_model,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = range(empty_data@doseGrid),
      increments = c(2, 2)
    ),
    nextBest = NextBestTD(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3
    ),
    cohort_size = CohortSizeConst(size = 3),
    data = empty_data,
    startingDose = 25
  )
}

# DualResponsesSamplesDesign ----

## class ----

#' `DualResponsesSamplesDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a class of design based on DLE responses using the [`LogisticIndepBeta`] model
#  and efficacy responses using [`ModelEff`]  model class
#' with DLE and efficacy samples. It contain all slots in
#' [`RuleDesign`] and [`TDsamplesDesign`] class objects.
#
#' @slot data (`DataDual`)\cr the data set.
#' @slot eff_model (`ModelEff`)\cr the pseudo efficacy model to be used.
#'
#' @aliases DualResponsesSamplesDesign
#' @export
#'
.DualResponsesSamplesDesign <-
  setClass(
    Class = "DualResponsesSamplesDesign",
    slots = c(
      eff_model = "ModelEff",
      data = "DataDual"
    ),
    prototype = prototype(
      nextBest = .NextBestMaxGainSamples(),
      data = DataDual(doseGrid = 1:2),
      startingDose = 1,
      model = .LogisticIndepBeta()
    ),
    contains = "TDsamplesDesign"
  )

## constructor ----

#' @rdname DualResponsesSamplesDesign-class
#'
#' @param data (`DataDual`)\cr see slot definition.
#' @param eff_model (`ModelEff`)\cr see slot definition.
#' @inheritDotParams TDsamplesDesign
#'
#' @example examples/Design-class-DualResponsesSamplesDesign.R
#' @export
#'
DualResponsesSamplesDesign <- function(eff_model, data, ...) {
  start <- TDsamplesDesign(data = data, ...)
  .DualResponsesSamplesDesign(
    start,
    eff_model = eff_model,
    data = data
  )
}

## default constructor ----

#' @rdname DualResponsesSamplesDesign-class
#' @note Typically, end users will not use the `.DefaultDualResponsesSamplesDesign()` function.
#' @export
.DefaultDualResponsesSamplesDesign <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))

  tox_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )
  options <- McmcOptions(burnin = 100, step = 2, samples = 200)
  tox_samples <- mcmc(empty_data, tox_model, options)

  eff_model <- Effloglog(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    nu = c(a = 1, b = 0.025),
    data = empty_data
  )
  eff_samples <- mcmc(empty_data, eff_model, options)

  my_next_best <- NextBestMaxGainSamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, prob = 0.3))
    },
    mg_derive = function(mg_samples) {
      as.numeric(quantile(mg_samples, prob = 0.5))
    }
  )

  DualResponsesSamplesDesign(
    nextBest = my_next_best,
    cohort_size = CohortSizeConst(size = 3),
    startingDose = 25,
    model = tox_model,
    eff_model = eff_model,
    data = empty_data,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = c(25, 300),
      increments = c(2, 2)
    )
  )
}

# DualResponsesDesign.R ----

## class ----

#' `DualResponsesDesign.R`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a class of design based on DLE responses using the [`LogisticIndepBeta`] model
#  and efficacy responses using the [`ModelEff`]  model class
#' without DLE and efficacy samples. It contains all slots from the
#' [`RuleDesign`] and [`TDsamplesDesign`] classes.
#
#' @slot data (`DataDual`)\cr the data set.
#' @slot eff_model (`ModelEff`)\cr the pseudo efficacy model to be used.
#'
#' @aliases DualResponsesDesign
#' @export
#'
.DualResponsesDesign <-
  setClass(
    Class = "DualResponsesDesign",
    slots = c(
      eff_model = "ModelEff",
      data = "DataDual"
    ),
    prototype = prototype(
      nextBest = .NextBestMaxGain(),
      data = DataDual(doseGrid = 1:2),
      startingDose = 1,
      model = .LogisticIndepBeta()
    ),
    contains = "TDDesign"
  )

## constructor ----

#' @rdname DualResponsesDesign-class
#'
#' @param data (`DataDual`)\cr see slot definition.
#' @param eff_model (`ModelEff`)\cr see slot definition.
#' @inheritDotParams TDDesign
#'
#' @example examples/Design-class-DualResponsesDesign.R
#' @export
#'
DualResponsesDesign <- function(eff_model, data, ...) {
  start <- TDDesign(data = data, ...)
  .DualResponsesDesign(
    start,
    eff_model = eff_model,
    data = data
  )
}

## default constructor ----

#' @rdname DualResponsesDesign-class
#' @note Typically, end users will not use the `.DefaultDualResponsesDesign()` function.
#' @export
.DefaultDualResponsesDesign <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))

  DualResponsesDesign(
    nextBest = NextBestMaxGain(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3
    ),
    cohort_size = CohortSizeConst(size = 3),
    startingDose = 25,
    model = LogisticIndepBeta(
      binDLE = c(1.05, 1.8),
      DLEweights = c(3, 3),
      DLEdose = c(25, 300),
      data = empty_data
    ),
    eff_model = Effloglog(
      eff = c(1.223, 2.513),
      eff_dose = c(25, 300),
      nu = c(a = 1, b = 0.025),
      data = empty_data
    ),
    data = empty_data,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = c(25, 300),
      increments = c(2, 2)
    )
  )
}


# DADesign ----

## class ----

#' `DADesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class has special requirements for the `model` and `data`
#' slots in comparison to the parent class [`Design`]:
#'
#' @slot model (`GeneralModel`)\cr the model to use, see in particular [`DALogisticLogNormal`] and
#' [`TITELogisticLogNormal`] which make use of the time-to-DLT data.
#' @slot data (`DataDA`)\cr what is the dose grid, any previous data, etc.
#' @slot safetyWindow (`SafetyWindow`)\cr the safety window to apply between cohorts.
#'
#' @details
#' The `safetyWindow` slot should be an instance of the `SafetyWindow` class.
#' It can be customized to specify the duration of the safety window for your trial.
#' The safety window represents the time period required to observe toxicity data
#' from the ongoing cohort before opening the next cohort.
#' Note that even after opening the next cohort,
#' further toxicity data will be collected and analyzed to make dose escalation decisions.
#'
#'
#' To specify a constant safety window, use the `SafetyWindowConst` constructor. For example:
#'
#' \code{mysafetywindow <- SafetyWindowConst(c(6, 2), 10, 20)}
#'
#' @seealso [`SafetyWindowConst`] for creating a constant safety window.
#'
#' @aliases DADesign
#' @export
#'
.DADesign <-
  setClass(
    Class = "DADesign",
    slots = c(
      model = "GeneralModel",
      data = "DataDA",
      safetyWindow = "SafetyWindow"
    ),
    prototype = prototype(
      model = .DALogisticLogNormal(),
      nextBest = .NextBestNCRM(),
      data = DataDA(doseGrid = 1:2),
      safetyWindow = .SafetyWindowConst()
    ),
    contains = "Design"
  )


## constructor ----

#' @rdname DADesign-class
#'
#' @param model (`GeneralModel`)\cr see slot definition.
#' @param data (`DataDA`)\cr see slot definition.
#' @param safetyWindow (`SafetyWindow`)\cr see slot definition.
#' @inheritDotParams Design
#'
#' @example examples/Design-class-DADesign.R
#' @export
#'
DADesign <- function(model, data, safetyWindow, ...) {
  start <- Design(
    data = data,
    model = model,
    ...
  )
  .DADesign(start, safetyWindow = safetyWindow)
}

## default constructor ----

#' @rdname DADesign-class
#' @note Typically, end users will not use the `.DefaultDADesign()` function.
#' @export
.DefaultDADesign <- function() {
  emptydata <- DataDA(
    doseGrid = c(0.1, 0.5, 1, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    Tmax = 60
  )

  npiece_ <- 10
  t_max_ <- 60

  lambda_prior <- function(k) {
    npiece_ / (t_max_ * (npiece_ - k + 0.5))
  }

  model <- DALogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 56,
    npiece = npiece_,
    l = as.numeric(t(apply(
      as.matrix(c(1:npiece_), 1, npiece_),
      2,
      lambda_prior
    ))),
    c_par = 2
  )

  mySize1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  mySize2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  mySize <- maxSize(mySize1, mySize2)

  myStopping1 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  myStopping2 <- StoppingMinPatients(nPatients = 50)
  myStopping <- (myStopping1 | myStopping2)

  DADesign(
    model = model,
    increments = IncrementsRelative(
      intervals = c(0, 20),
      increments = c(1, 0.33)
    ),
    nextBest = NextBestNCRM(
      target = c(0.2, 0.35),
      overdose = c(0.35, 1),
      max_overdose_prob = 0.25
    ),
    stopping = myStopping,
    cohort_size = mySize,
    data = emptydata,
    safetyWindow = SafetyWindowConst(c(6, 2), 7, 7),
    startingDose = 3
  )
}
# DesignGrouped ----

## class ----

#' `DesignGrouped`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DesignGrouped`] combines two [`Design`] objects: one for the mono and one
#' for the combo arm of a joint dose escalation design.
#'
#' @slot model (`LogisticLogNormalGrouped`)\cr the model to be used, currently only one
#'   class is allowed.
#' @slot mono (`Design`)\cr defines the dose escalation rules for the mono arm, see
#'   details.
#' @slot combo (`Design`)\cr defines the dose escalation rules for the combo arm, see
#'   details.
#' @slot first_cohort_mono_only (`flag`)\cr whether first test one mono agent cohort, and then
#'   once its DLT data has been collected, we proceed from the second cohort onwards with
#'   concurrent mono and combo cohorts.
#' @slot same_dose_for_all (`flag`)\cr whether the lower dose of the separately determined mono and combo
#'   doses should be used as the next dose for both mono and combo in all cohorts.
#' @slot same_dose_for_start (`flag`)\cr indicates whether, when mono and combo are
#'   used in the same cohort for the first time, the same dose should be used for both.
#'   Note that this is different from `same_dose_for_all` which will always force
#'   them to be the same. If `same_dose_for_all = TRUE`, this is therefore ignored. See Details.
#'
#' @details
#'
#'   - Note that the model slots inside the `mono` and `combo` parameters
#'     are ignored (because we don't fit separate regression models for the mono and
#'     combo arms). Instead, the `model` parameter is used to fit a joint regression
#'     model for the mono and combo arms together.
#'   - `same_dose_for_start = TRUE` is useful as an option when we want to use `same_dose_for_all = FALSE`
#'     combined with `first_cohort_mono_only = TRUE`.
#'     This will allow to randomize patients to the mono and combo arms at the same dose
#'     as long as the selected dose for the cohorts stay the same. This can therefore
#'     further mitigate bias as long as possible between the mono and combo arms.
#'
#' @aliases DesignGrouped
#' @export
#'
.DesignGrouped <- setClass(
  Class = "DesignGrouped",
  slots = c(
    model = "LogisticLogNormalGrouped",
    mono = "Design",
    combo = "Design",
    first_cohort_mono_only = "logical",
    same_dose_for_all = "logical",
    same_dose_for_start = "logical"
  ),
  prototype = prototype(
    model = .DefaultLogisticLogNormalGrouped(),
    mono = .Design(),
    combo = .Design(),
    first_cohort_mono_only = TRUE,
    same_dose_for_all = TRUE,
    same_dose_for_start = FALSE
  ),
  validity = v_design_grouped,
  contains = "CrmPackClass"
)

## constructor ----

#' @rdname DesignGrouped-class
#'
#' @param model (`LogisticLogNormalGrouped`)\cr see slot definition.
#' @param mono (`Design`)\cr see slot definition.
#' @param combo (`Design`)\cr see slot definition.
#' @param first_cohort_mono_only (`flag`)\cr see slot definition.
#' @param same_dose_for_all (`flag`)\cr see slot definition.
#' @param same_dose_for_start (`flag`)\cr see slot definition.
#' @param stop_mono_with_combo (`flag`)\cr whether the mono arm should be stopped when the combo
#'   arm is stopped (this makes sense when the only real trial objective is the recommended combo dose).
#' @param ... not used.
#'
#' @export
#' @example examples/Design-class-DesignGrouped.R
#'
DesignGrouped <- function(
  model,
  mono,
  combo = mono,
  first_cohort_mono_only = TRUE,
  same_dose_for_all = !same_dose_for_start,
  same_dose_for_start = FALSE,
  stop_mono_with_combo = FALSE,
  ...
) {
  assert_flag(stop_mono_with_combo)
  assert_class(mono, "Design")
  force(combo)
  if (stop_mono_with_combo) {
    mono@stopping <- mono@stopping |
      StoppingExternal(report_label = "Stop Mono with Combo")
  }

  .DesignGrouped(
    model = model,
    mono = mono,
    combo = combo,
    first_cohort_mono_only = first_cohort_mono_only,
    same_dose_for_all = same_dose_for_all,
    same_dose_for_start = same_dose_for_start
  )
}

## default constructor ----

#' @rdname DesignGrouped-class
#' @note Typically, end-users will not use the `.DefaultDesignGrouped()` function.
#' @export
.DefaultDesignGrouped <- .DesignGrouped

# RuleDesignOrdinal ----

## class ----

#' `RuleDesignOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`RuleDesignOrdinal`] is the class for rule-based designs. The difference between
#' this class and the [`DesignOrdinal`] class is that [`RuleDesignOrdinal`]
#' does not contain `model`, `stopping` and `increments` slots.
#'
#' @details Please note that the cohort size rules need to be wrapped into
#' the corresponding [CohortSizeOrdinal] class, before a successful evaluation of the
#' corresponding methods can take place. Note also that these wrappers cannot be nested,
#' i.e., you cannot have a [CohortSizeOrdinal] inside another [CohortSizeOrdinal]
#' (which also would not make sense) because it would not be clear which event grade to use
#' for the methods calculation. However, multiple rules can be combined using the operators
#' defined, e.g.,
#' `CohortSizeMin(list(CohortSizeOrdinal(1L, rule1), CohortSizeOrdinal(2L, rule2)))`.
#'
#' @slot next_best (`NextBestOrdinal`)\cr how to find the next best dose.
#' @slot cohort_size (`CohortSize`)\cr rules for the cohort sizes.
#' @slot data (`DataOrdinal`)\cr specifies dose grid, any previous data, etc.
#' @slot starting_dose (`number`)\cr the starting dose, it must lie on the dose
#'   grid in `data`.
#'
#' @aliases RuleDesignOrdinal
#' @export
#'
.RuleDesignOrdinal <- setClass(
  Class = "RuleDesignOrdinal",
  slots = c(
    next_best = "NextBestOrdinal",
    cohort_size = "CohortSize",
    data = "DataOrdinal",
    starting_dose = "numeric"
  ),
  prototype = prototype(
    next_best = .NextBestOrdinal(),
    cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(3L)),
    data = DataOrdinal(doseGrid = 1:3),
    starting_dose = 1
  ),
  contains = "CrmPackClass",
  validity = v_rule_design_ordinal
)

## constructor ----

#' @rdname RuleDesignOrdinal-class
#'
#' @param next_best (`NextBestOrdinal`)\cr see slot definition.
#' @param cohort_size (`CohortSize`)\cr see slot definition.
#' @param data (`DataOrdinal`)\cr see slot definition.
#' @param starting_dose (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Design-class-RuleDesignOrdinal.R
#'
RuleDesignOrdinal <- function(
  next_best,
  cohort_size,
  data,
  starting_dose
) {
  new(
    "RuleDesignOrdinal",
    next_best = next_best,
    cohort_size = cohort_size,
    data = data,
    starting_dose = as.numeric(starting_dose)
  )
}

#' @rdname RuleDesignOrdinal-class
#' @note Typically, end users will not use the `.DefaultRuleDesignOrdinal()` function.
#' @export

.DefaultRuleDesignOrdinal <- function() {
  RuleDesignOrdinal(
    next_best = NextBestOrdinal(
      1L,
      NextBestMTD(target = 0.25, derive = function(x) mean(x, na.rm = TRUE))
    ),
    cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(size = 3L)),
    data = DataOrdinal(doseGrid = c(5, 10, 15, 25, 35, 50, 80)),
    starting_dose = 5
  )
}

# DesignOrdinal ----

## class ----

#' `DesignOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DesignOrdinal`] is the class for rule-based ordinal designs. The difference
#' between this class and its parent [`RuleDesignOrdinal`] class is that the
#'  [`DesignOrdinal`] class contains additional `model`, `stopping`,
#'  `increments` and `pl_cohort_size` slots.
#'
#' @details Please note that stopping, increments or cohort size rules need to be wrapped into
#' the corresponding [StoppingOrdinal], [IncrementsOrdinal] or [CohortSizeOrdinal] classes, before
#' a successful evaluation of the corresponding methods can take place.
#' Note also that these wrappers cannot be nested, i.e., you cannot have an [IncrementsOrdinal] inside
#' another [IncrementsOrdinal] (which also would not make sense) because it would not be clear which
#' event grade to use for the methods calculation.
#' However, multiple rules can be combined using the operators defined for these classes, e.g.,
#' `StoppingOrdinal(1L, rule1 & rule2) | StoppingOrdinal(2L, rule3)`.
#'
#' @slot model (`LogisticLogNormalOrdinal`)\cr the model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases DesignOrdinal
#' @export
#'
.DesignOrdinal <- setClass(
  Class = "DesignOrdinal",
  slots = c(
    model = "LogisticLogNormalOrdinal",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticLogNormalOrdinal(),
    next_best = .NextBestOrdinal(),
    stopping = .StoppingOrdinal(),
    increments = .IncrementsOrdinal(),
    pl_cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(3L))
  ),
  contains = "RuleDesignOrdinal"
)

## constructor ----

#' @rdname DesignOrdinal-class
#'
#' @param model (`LogisticLogNormalOrdinal`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesignOrdinal
#'
#' @export
#' @example examples/Design-class-DesignOrdinal.R
#'
#'
DesignOrdinal <- function(
  model,
  stopping,
  increments,
  pl_cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(0L)),
  ...
) {
  start <- RuleDesignOrdinal(...)
  new(
    "DesignOrdinal",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname DesignOrdinal-class
#' @note Typically, end users will not use the `.DefaultDesignOrdinal()` function.
#' @export
.DefaultDesignOrdinal <- function() {
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- CohortSizeOrdinal(1L, maxSize(my_size1, my_size2))

  my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
  my_stopping2 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  my_stopping3 <- StoppingMinPatients(nPatients = 20)
  my_stopping <- StoppingOrdinal(
    1L,
    (my_stopping1 & my_stopping2) | my_stopping3
  )

  # Initialize the design.
  design <- DesignOrdinal(
    model = LogisticLogNormalOrdinal(
      mean = c(-3, -4, 1),
      cov = diag(c(3, 4, 1)),
      ref_dose = 50
    ),
    next_best = NextBestOrdinal(
      1L,
      NextBestNCRM(
        target = c(0.2, 0.35),
        overdose = c(0.35, 1),
        max_overdose_prob = 0.25
      )
    ),
    stopping = my_stopping,
    increments = IncrementsOrdinal(
      1L,
      IncrementsRelative(
        intervals = c(0, 20),
        increments = c(1, 0.33)
      )
    ),
    cohort_size = my_size,
    data = DataOrdinal(
      doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
      yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L)
    ),
    starting_dose = 3
  )
}

#' Helpers for stripping expressions of `covr`-inserted trace code
#'
#' Workarounds to allow the package to continue to work while running `covr`
#' with minimal changes to the package code.
#'
#' @details
#' When using `covr`, the source code for package objects are modified to add
#' callbacks for each expression to log its execution. Given an arbitrary
#' expression, such as:
#'
#'     expr
#'
#' The code will be modified before executing any package code to look like:
#'
#'     if (TRUE) {
#'       covr:::count("file.R:1:2:3:4:5:6:7:8")
#'       expr
#'     }
#'
#' These functions are used for stripping expressions of this code so that the
#' package continues to work as intended while running tests as part of running
#' `covr` to calculate package coverage.
#'
#' This method is non-exhaustive, covering only a subset of `covr`'s tracing
#' behaviors necessary for this package.
#'
#' @param expr (`language`)\cr an R expression or call to test or strip of
#'   `covr` trace counters.
#'
#' @return A logical value or transformed expression with calls to
#'   `covr:::count` removed.
#'
#' @name h_covr_helpers
#' @keywords internal
#'
NULL

#' @describeIn h_covr_helpers
#' Determine whether `covr` is currently running
h_covr_active <- function() {
  identical(Sys.getenv("R_COVR"), "true")
}

#' @describeIn h_covr_helpers
#' Remove `covr` traces from an expression
h_covr_detrace <- function(expr) {
  if (!h_covr_active()) {
    return(expr)
  }

  if (is.function(expr)) {
    body(expr) <- h_covr_detrace(body(expr))
    return(expr)
  }

  detrace <- function(x) {
    # returns "missing" expression to avoid errors with calls
    if (identical(x, bquote())) {
      return(x)
    }

    x <- h_covr_detrace_call(x)
    if (is.call(x)) {
      x[-1] <- lapply(x[-1], h_covr_detrace)
    }
    x
  }

  detrace(expr)
}

#' @describeIn h_covr_helpers
#' Determine whether the current expression is a `covr`-modified expression
h_is_covr_trace <- function(expr) {
  # Matches `if (TRUE) { covr:::count(<trace>); <expr> }` (see covr:::trace_calls).
  is.call(expr) &&
    expr[[1]] == "if" &&
    expr[[2]] == quote(TRUE) &&
    expr[[3]][[1]] == "{" &&
    length(expr[[3]]) >= 3 &&
    is.call(expr[[3]][[2]]) &&
    expr[[3]][[2]][[1]] == call(":::", as.symbol("covr"), as.symbol("count"))
}

#' @describeIn h_covr_helpers
#' Extract the original expression from a `covr`-modified expression
h_covr_detrace_call <- function(expr) {
  if (h_is_covr_trace(expr)) expr[[3]][[3]] else expr
}

# Design ----

#' Internal Helper Functions for Validation of [`RuleDesign`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`RuleDesign`] or inherited classes and therefore not exported.
#'
#' @name v_design
#' @param object (`RuleDesign`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_design validates that the [`RuleDesign`] object
#'   contains valid `startingDose`.
v_rule_design <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@startingDose, finite = TRUE),
    "startingDose must be a number"
  )
  v$check(
    test_subset(
      object@startingDose,
      choices = object@data@doseGrid,
      empty.ok = FALSE
    ),
    "startingDose must be included in data@doseGrid"
  )
  v$result()
}

#' Internal Helper Functions for Validation of [`RuleDesignOrdinal`] Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an input
#' [`RuleDesignOrdinal`] or inherited classes and therefore not exported.
#'
#' @name v_design
#' @param object (`RuleDesignOrdinal`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_design validates that the [`RuleDesignOrdinal`] object
#'   contains valid `starting_dose`.
v_rule_design_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@starting_dose, finite = TRUE),
    "starting_dose must be a number"
  )
  v$check(
    test_subset(
      object@starting_dose,
      choices = object@data@doseGrid,
      empty.ok = FALSE
    ),
    "starting_dose must be included in data@doseGrid"
  )
  v$result()
}


#' @describeIn v_design validates that the [`DesignGrouped`] object
#'   contains valid flags.
v_design_grouped <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@first_cohort_mono_only),
    "first_cohort_mono_only must be a flag"
  )
  v$check(
    test_flag(object@same_dose_for_all),
    "same_dose_for_all must be a flag"
  )
  v$check(
    test_flag(object@same_dose_for_all),
    "same_dose_for_start must be a flag"
  )
  v$result()
}

# Integration with knitr ----
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional utility functions to allow human-friendly rendition of
#' crmPack objects in Markdown and Quarto files
#'
#' @return a character string that represents the object in markdown.
#' @name knit_print
NULL

# Helpers ---

#' Helper Function to Convert a `gap` Slot to Words
#'
#' @inheritParams knit_print.SafetyWindowConst
#' @param gap (`numeric`)\cr a vector of gaps
#' @return a Markdown representation of the `gap` parameter as a bullet list.
#' @noRd
#' @keywords internal
h_describe_safety_gap <- function(gap, ordinals, label, time_unit) {
  assert_character(
    ordinals,
    min.len = length(gap) - 1,
    any.missing = FALSE,
    unique = TRUE
  )

  if (length(gap) == 1) {
    paste0(
      "- The gap between consecutive enrolments should always be at least ",
      gap[1],
      " ",
      ifelse(gap[1] == 1, time_unit[1], time_unit[2]),
      ".\n\n"
    )
  } else {
    paste0(
      paste0(
        lapply(
          seq_along(1:(length(gap) - 1)),
          function(n) {
            paste0(
              "-  The gap between the enrolment of the ",
              ordinals[n],
              " and the ",
              ordinals[n + 1],
              " ",
              label[2],
              " in the cohort should be at least ",
              gap[n],
              " ",
              ifelse(gap[n] == 1, time_unit[1], time_unit[2])
            )
          }
        ),
        collapse = "\n\n"
      ),
      "\n",
      paste0(
        "- The gap between all subsequent ",
        label[2],
        " should be at least ",
        gap[length(gap)],
        " ",
        ifelse(gap[length(gap)] == 1, time_unit[1], time_unit[2]),
        "\n"
      ),
      sep = "\n"
    )
  }
}
# Methods ----

# SafetyWindow ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' `label` should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a count of 1 and the second describes all other counts.
#' If of length 1, the character `s` is appended to the value when the count is not 1.
#' @rdname knit_print
#' @export
#' @method knit_print SafetyWindow
knit_print.SafetyWindow <- function(
  x,
  ...,
  asis = TRUE,
  time_unit = "day",
  label = "participant"
) {
  assert_character(time_unit, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_flag(asis)

  label <- h_prepare_labels(label)
  if (length(time_unit) == 1) {
    time_unit[2] <- paste0(time_unit[1], "s")
  }

  rv <- paste0(
    "To protect the welfare of individual ",
    label[2],
    ", the rate of enrolment within each cohort will be restricted.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# SafetyWindowConst ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @inheritParams knit_print.CohortSizeConst
#' @param time_unit (`character`)\cr the word used to describe units of time.
#' See Usage Notes below.
#' @param ordinals (`character`)\cr a character vector whose nth defines the
#' word used as the written representation of the nth ordinal number.
#' @section Usage Notes:
#' `label` and `time_unit` are, collectively, labels.
#'
#' A label should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a count of 1 and the second describes all other counts.
#' If of length 1, the character `s` is appended to the value when the count is not 1.
#' @rdname knit_print
#' @export
#' @method knit_print SafetyWindowConst
knit_print.SafetyWindowConst <- function(
  x,
  ...,
  asis = TRUE,
  label = "participant",
  ordinals = c(
    "first",
    "second",
    "third",
    "fourth",
    "fifth",
    "sixth",
    "seventh",
    "eighth",
    "ninth",
    "tenth"
  ),
  time_unit = "day"
) {
  assert_character(time_unit, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_character(
    ordinals,
    min.len = length(x@gap) - 1,
    any.missing = FALSE,
    unique = TRUE
  )
  assert_flag(asis)

  label <- h_prepare_labels(label)
  if (length(time_unit) == 1) {
    time_unit[2] <- paste0(time_unit[1], "s")
  }

  rv <- paste0(
    knit_print.SafetyWindow(x, asis = FALSE, label = label, ...),
    "For all cohorts:\n\n",
    h_describe_safety_gap(x@gap, ordinals, label, time_unit),
    "Before the next cohort can open, all ",
    label[2],
    " in the current cohort must have been followed up for at least ",
    x@follow,
    " ",
    ifelse(x@follow == 1, time_unit[1], time_unit[2]),
    " and at least one ",
    label[1],
    " must have been followed up for at least ",
    x@follow_min,
    " ",
    ifelse(x@follow_min == 1, time_unit[1], time_unit[2]),
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# SafetyWindowSize ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.SafetyWindowConst
#' @inherit SafetyWindowConst sections
#' @param level (`count`)\cr the markdown level at which the headings for cohort size
#' will be printed.  An integer between 1 and 6
#' @rdname knit_print
#' @export
#' @method knit_print SafetyWindowSize
knit_print.SafetyWindowSize <- function(
  x,
  ...,
  asis = TRUE,
  # We could use package english here and avoid the need for `ordinals`, but
  # is an extra dependency for very limited benefit
  ordinals = c(
    "first",
    "second",
    "third",
    "fourth",
    "fifth",
    "sixth",
    "seventh",
    "eighth",
    "ninth",
    "tenth"
  ),
  label = "participant",
  time_unit = "day",
  level = 2L
) {
  assert_character(time_unit, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_flag(asis)
  assert_integer(level, lower = 1, upper = 6, any.missing = FALSE)

  label <- h_prepare_labels(label)
  if (length(time_unit) == 1) {
    time_unit[2] <- paste0(time_unit[1], "s")
  }

  rv <- paste0(
    knit_print.SafetyWindow(x, asis = FALSE, label = label, ...),
    paste0(
      lapply(
        seq_along(x@size),
        function(i) {
          paste0(
            dplyr::case_when(
              i == 1 ~
                paste0(
                  stringr::str_dup("#", level),
                  " For cohort sizes of less than ",
                  x@size[2]
                ),
              i == length(x@size) ~
                paste0(
                  stringr::str_dup("#", level),
                  " For cohort sizes of ",
                  x@size[i],
                  " or more"
                ),
              TRUE ~
                paste0(
                  stringr::str_dup("#", level),
                  " For cohort sizes greater than or equal to ",
                  x@size[i],
                  " and strictly less than ",
                  x@size[i + 1]
                )
            ),
            "\n\n",
            h_describe_safety_gap(x@gap[[i]], ordinals, label, time_unit)
          )
        }
      ),
      collapse = "\n"
    )
  )

  rv <- paste0(
    rv,
    "For all cohorts, before the next cohort can open, all ",
    label[2],
    " in the current cohort must have been followed up for at least ",
    x@follow,
    " ",
    ifelse(x@follow == 1, time_unit[1], time_unit[2]),
    " and at least one ",
    label[1],
    " must have been followed up for at least ",
    x@follow_min,
    " ",
    ifelse(x@follow_min == 1, time_unit[1], time_unit[2]),
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Convenience function to make barplots of percentages
#'
#' @param x vector of samples
#' @param description xlab string
#' @param xaxisround rounding for xaxis labels (default: 0, i.e. integers will
#' be used)
#'
#' @return the ggplot2 object
#'
#' @keywords internal
#' @importFrom ggplot2 ggplot geom_histogram aes xlab ylab xlim
h_barplot_percentages <- function(x, description, xaxisround = 0) {
  assert_number(xaxisround, lower = 0)
  assert_character(description, len = 1, any.missing = FALSE)
  assert_numeric(x)

  tabx <- table(x) / length(x)
  dat <- data.frame(x = as.numeric(names(tabx)), perc = as.numeric(tabx) * 100)
  ggplot() +
    geom_bar(
      aes(x = x, y = perc),
      data = dat,
      stat = "identity",
      position = "identity",
      width = ifelse(nrow(dat) > 1, min(diff(dat$x)) / 2, 1)
    ) +
    xlab(description) +
    ylab("Percent") +
    scale_x_continuous(
      breaks = round(dat$x, xaxisround)
    )
}


#' Helper function to calculate percentage of true stopping rules for
#' report label output
#' calculates true column means and converts output into percentages
#' before combining the output with the report label; output is passed
#' to [`show()`] and output with cat to console
#'
#' @param stop_report object from summary method
#' @return named list with label and percentage of rule activation

h_calc_report_label_percentage <- function(stop_report) {
  stop_pct <- colMeans(stop_report) * 100
  stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
  stop_pct_to_print
}


#' Helper function to calculate average across iterations for each additional
#' reporting parameter
#' extracts parameter names as specified by user and averaged the values
#' for each specified parameter to [`show()`] and output with cat to console
#'
#' @param stats_list object from simulation with nested parameter values
#' (sublist for each parameter)
#' @return list of parameter names and averaged values for console output

h_summarize_add_stats <- function(stats_list) {
  # Extract the parameter names
  param_names <- names(stats_list[[1]])

  # Calculate the average for each parameter
  averages <- lapply(param_names, function(param) {
    values <- sapply(stats_list, function(x) x[[param]])
    mean(values)
  })

  list(param_names, averages)
}

# GeneralSimulations ----

#' Internal Helper Functions for Validation of [`GeneralSimulations`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralSimulations`] or inherited classes and therefore not exported.
#'
#' @name v_general_simulations
#' @param object (`GeneralSimulations`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_general_simulations validates that the [`GeneralSimulations`] object
#'   contains valid `data` object and valid `dose` simulations.

v_general_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    all(sapply(object@data, is, "Data")),
    "all data elements must be Data objects"
  )
  v$check(
    identical(length(object@doses), nSims),
    "doses must have same length as the data list"
  )

  v$result()
}

#' @describeIn v_general_simulations validates that the [`Simulations`] object
#'   contains valid object `fit`, `stop_reasons`, `stop_report`, and
#'   `additional_stats` compared to the general class [`GeneralSimulations`].
#'
v_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@fit), nSims),
    "fit must have same length as data"
  )
  v$check(
    identical(length(object@stop_reasons), nSims),
    "stop_reasons must have same length as data"
  )

  v$check(
    checkmate::test_matrix(
      object@stop_report,
      mode = "logical",
      nrows = nSims,
      min.cols = 1,
      any.missing = FALSE
    ),
    "stop_report must be a matrix of mode logical in which the number of rows
    equals the number of simulations and which must not contain any missing values"
  )

  v$result()
}

#' @describeIn v_general_simulations validates that the [`DualSimulations`] object and
#' capture the dose-biomarker `fits`, and the `sigma2W` and `rho` estimates.
#'
v_dual_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@fit_biomarker), nSims),
    "fit_biomarker list has to have same length as data"
  )
  v$check(
    identical(length(object@rho_est), nSims),
    "rho_est vector has to have same length as data"
  )
  v$check(
    identical(length(object@sigma2w_est), nSims),
    "sigma2w_est has to have same length as data"
  )

  v$result()
}

# PseudoSimulations ----

#' Internal Helper Functions for Validation of [`PseudoSimulations`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`PseudoSimulations`] or inherited classes and therefore not exported.
#'
#' @name v_pseudo_simulations
#' @param object (`PseudoSimulations`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_pseudo_simulations validates that the [`PseudoSimulations`] object
#'   contains valid `fit`, `FinalTDtargetEndOfTrialEstimates` ,
#'   `FinalTDtargetDuringTrialAtDoseGrid`,`FinalTDtargetEndOfTrialAtDoseGrid` ,
#'   `FinalTDEOTCIs`, `FinalTDEOTRatios`, `FinalCIs`, `FinalRatios`,
#'     object and valid `stopReasons` simulations.

v_pseudo_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)
  v$check(
    identical(length(object@stop_reasons), nSims),
    "stopReasons must have same length as data"
  )

  v$result()
}

#' @describeIn v_pseudo_simulations validates that the [`PseudoDualSimulations`] object
#'   contains valid `fit_eff`, `final_gstar_estimates` , `final_gstar_at_dose_grid`,
#'    `final_gstar_cis` , `final_gstar_ratios`, `final_optimal_dose`, `final_optimal_dose_at_dose_grid`
#'     object and valid `sigma2_est` simulations.

v_pseudo_dual_simulations <- function(object) {
  v <- Validate()
  nSims <- length(object@data)
  v$check(
    identical(length(object@sigma2_est), nSims),
    "sigma2_est has to have same length as data"
  )
  v$result()
}

#' @describeIn v_pseudo_simulations validates that the [`PseudoDualFlexiSimulations`]
#' object contains valid `sigma2_beta_w_est` vector of the final posterior mean
#' sigma2betaW estimates.`FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
#'
v_pseudo_dual_flex_simulations <- function(object) {
  v <- Validate()
  nSims <- length(object@data)
  v$check(
    identical(length(object@sigma2_beta_w_est), nSims),
    "sigma2_beta_w_est has to have same length as data"
  )
  v$result()
}

#' @describeIn v_general_simulations validates that the [`DASimulations`] object
#'   contains valid `trial_duration` the vector of trial duration values for all
#'   simulations.

v_da_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@trial_duration), nSims),
    "trial_duration vector has to have same length as data"
  )

  v$result()
}

#' Helper Function to Blind Plot Data
#'
#' @param df (`GeneralData`)\cr The data to be blinded
#' @param blind (`flag`)\cr Should the data be blinded?
#' @param has_placebo (`flag`)\cr Does the data contain a placebo dose?
#' @param pbo_dose (`positive_number`)\cr The dose to be taken as placebo.
#' Ignored if `has_placebo` is `FALSE`
#' @returns The blinded data
h_blind_plot_data <- function(df, blind, has_placebo, pbo_dose) {
  if (blind) {
    # This is to blind the data.
    # For each cohort, all DLTs are assigned to the first subjects in the cohort.
    # In addition, the placebo (if any) is set to the active dose level for that
    # cohort.
    # Notice: dapply reorders records of df according to the lexicographic order
    # of cohort.
    df <- dapply(df, f = ~cohort, FUN = function(coh) {
      coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
      coh$dose <- max(coh$dose)
      coh
    })
  } else if (has_placebo) {
    # Placebo will be plotted at y = 0 level.
    df$dose[df$dose == pbo_dose] <- 0
  }
  df
}

# h_plot_data_df ----

## generic ----

#' Helper Function for the Plot Method of subclasses of [`GeneralData`]
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that transforms [`GeneralData`]  objects into a `tibble` suitable for
#' plotting with `ggplot2` methods
#'
#' @param data (`GeneralData`)\cr object from which data is extracted and converted
#' into a data frame.
#' @param ... further arguments passed to class-specific methods.
#' @return `data.frame` containing columns for patient, cohort, dose and toxicity grade
#' @aliases h_plot_data_df
#'
setGeneric(
  name = "h_plot_data_df",
  def = function(data, ...) standardGeneric("h_plot_data_df"),
  valueClass = "data.frame"
)

# Data ----

#' Helper Function for the Plot Method of [`Data`]
#'
#' @param data (`Data`)\cr object from which data is extracted and converted
#'   into a data frame.
#' @param blind (`flag`)\cr should data be blinded?
#'   If `TRUE`, then for each cohort, all DLTs are assigned to the first
#'   subjects in the cohort. In addition, the placebo (if any) is set to the
#'   active dose level for that cohort.
#' @param legend (`flag`)\cr Display the legend for the toxicity categories
#' @param ... further arguments passed to `data.frame` constructor.
#'   It can be e.g. an extra `column_name = value` pair based on a slot
#'   from `x` (which in this case might be a subclass of `Data`)
#'   which does not appear in `Data`.
#' @return A `data.frame` object with columns patient, ID, cohort, dose and
#' toxicity.
#' @describeIn h_plot_data_df method for [`Data`].
setMethod(
  f = "h_plot_data_df",
  signature = signature(data = "Data"),
  definition = function(data, blind = FALSE, legend = TRUE, ...) {
    df <- data.frame(
      patient = seq_along(data@x),
      ID = paste(" ", data@ID),
      cohort = data@cohort,
      dose = data@x,
      toxicity = ifelse(data@y == 1, "Yes", "No"),
      ...
    )
    df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
    df
  }
)

# DataOrdinal ----

#' Helper Function for the Plot Method of [`DataOrdinal`]
#'
#' @describeIn h_plot_data_df Class specific method for [`DataOrdinal`]
setMethod(
  f = "h_plot_data_df",
  signature = signature(data = "DataOrdinal"),
  definition = function(data, blind = FALSE, legend = TRUE, ...) {
    df <- data.frame(
      patient = seq_along(data@x),
      ID = paste(" ", data@ID),
      cohort = data@cohort,
      dose = data@x,
      toxicity = names(data@yCategories)[1 + data@y],
      ...
    )
    df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
    df
  }
)


# h_plot_data_dataordinal

## Data ----

#' Helper Function for the Plot Method of the Data and DataOrdinal Classes
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`Data`]  and [`DataOrdinal`] objects.
#'
#' @note The default values of `tox_shapes` and `tox_labels` result in DLTs
#' being displayed as red triangles and other responses as black circles.
#' @return The [`ggplot2`] object.
#'
#' @rdname plot-Data
h_plot_data_dataordinal <- function(
  x,
  blind = FALSE,
  legend = TRUE,
  tox_labels = c(Yes = "red", No = "black"),
  tox_shapes = c(Yes = 17L, No = 16L),
  ...
) {
  assert_flag(blind)
  assert_flag(legend)
  assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
  assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
  assert_true(length(tox_shapes) == length(tox_labels))
  assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
  if (x@nObs == 0L) {
    return()
  }
  df <- h_plot_data_df(x, blind, ...)

  p <- ggplot(df, aes(x = patient, y = dose)) +
    geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
    scale_colour_manual(
      name = "Toxicity",
      values = tox_labels,
      breaks = names(tox_labels),
      guide = guide_legend(reverse = TRUE)
    ) +
    scale_shape_manual(
      name = "Toxicity",
      values = tox_shapes,
      breaks = names(tox_shapes),
      guide = guide_legend(reverse = TRUE)
    ) +
    scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
    scale_y_continuous(
      breaks = sort(unique(c(0, df$dose))),
      minor_breaks = NULL,
      limits = c(0, max(df$dose) * 1.1)
    ) +
    xlab("Patient") +
    ylab("Dose Level")

  p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)

  if (!blind) {
    p <- p +
      geom_text(
        aes(label = ID, size = 2),
        data = df,
        hjust = 0,
        vjust = 0.5,
        angle = 90,
        colour = "black",
        show.legend = FALSE
      )
  }

  if (!legend) {
    p <- p + theme(legend.position = "none")
  }

  p
}

#' Helper Function Containing Common Functionality
#'
#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
#' range is required
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
h_obtain_dose_grid_range <- function(object, ignore_placebo) {
  assert_flag(ignore_placebo)

  dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
    object@doseGrid[-1]
  } else {
    object@doseGrid
  }

  if (length(dose_grid) == 0L) {
    c(-Inf, Inf)
  } else {
    range(dose_grid)
  }
}

#' Convert a Ordinal Data to the Equivalent Binary Data for a Specific
#' Grade
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that takes a [`DataOrdinal`] object and an
#' integer grade and converts them to the equivalent `Data` object.
#'
#' @param data_ord (`DataOrdinal`)\cr the `DataOrdinal` object to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
#' is required.
#' @return A [`Data`] object.
#'
#' @export
h_convert_ordinal_data <- function(data_ord, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(data_ord, "DataOrdinal")
  # Execute
  Data(
    ID = data_ord@ID,
    cohort = data_ord@cohort,
    x = data_ord@x,
    y = as.integer(data_ord@y >= grade),
    doseGrid = data_ord@doseGrid,
    nGrid = data_ord@nGrid,
    xLevel = data_ord@xLevel,
    placebo = data_ord@placebo
  )
}

# Integration with knitr ----
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional utility functions to allow human-friendly rendition of
#' crmPack objects in Markdown and Quarto files
#'
#' @return a character string that represents the object in markdown.
#' @name knit_print
NULL

# CohortSize ----

#' Render a `CohortSizeConst` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @param x (`CohortSize`)\cr The object to knit_print.
#' @param asis (`flag`)\cr Should the return value be wrapped in a call to `knitr::asis_output`?
#' @param label (`character`)\cr The word used to label the participants.  See Usage Notes below.
#' @param ... Not used at present
#'
#' @section Usage Notes:
#' `label` describes the trial's participants.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a `cohort_size` of 1 and the second describes all other
#' `cohort_size`s.  If of length 1, the character `s` is appended to the value
#' when `cohort_size` is not 1.
#' @return The markdown representation of the object, as a character string
#' @seealso [`knit_print`] for more details.
#'
#' @export
#' @method knit_print CohortSizeConst
#' @rdname knit_print
knit_print.CohortSizeConst <- function(
  x,
  ...,
  asis = TRUE,
  label = c("participant", "participants")
) {
  assert_flag(asis)

  label <- h_prepare_labels(label)
  rv <- paste0(
    "A constant size of ",
    x@size,
    " ",
    label[ifelse(x@size == 1, 1, 2)],
    ".\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeRange` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @param ... passed to `knitr::kable`
#' @inherit knit_print.CohortSizeConst return
#' @section Usage Notes:
#' The default value of `col.names` is `c("Lower", "Upper", "Cohort size")` and
#' that of `caption` is `"Defined by the dose to be used in the next cohort"`.
#' These values can be overridden by passing `col.names` and `caption` in the
#' function call.
#' @export
#' @method knit_print CohortSizeRange
#' @rdname knit_print
knit_print.CohortSizeRange <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by the dose to be used in the next cohort"
  }
  x <- tidy(x)
  param[["x"]] <- x
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("Dose" = 2, " " = 1)
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeDLT` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... Passed to [knitr::kable()].
#'
#' @section Usage Notes:
#' The by default, the columns are labelled `Lower`, `Upper` and `Cohort size`.
#'  The table's caption is `Defined by the number of <tox_label[2]> so far observed`.
#'  These values can be overridden by passing `col.names` and `caption` in the
#'  function call.
#'
#' @export
#' @method knit_print CohortSizeDLT
#' @rdname knit_print
knit_print.CohortSizeDLT <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  param <- list(...)
  tox_label <- h_prepare_labels(tox_label)

  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- paste0(
      "Defined by the number of ",
      tox_label[2],
      " so far observed"
    )
  }
  param[["x"]] <- tidy(x)
  headers <- c(2, 1)
  names(headers) <- c(paste0("No of ", tox_label[2]), " ")
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    headers
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeParts` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritSection knit_print.CohortSizeConst Usage Notes
#'
#' @export
#' @method knit_print CohortSizeParts
#' @rdname knit_print
knit_print.CohortSizeParts <- function(
  x,
  ...,
  asis = TRUE,
  label = c("participant", "participants")
) {
  assert_flag(asis)

  label <- h_prepare_labels(label)
  rv <- paste0(
    "A size of ",
    x@cohort_sizes[1],
    " ",
    label[ifelse(x@cohort_sizes[1] == 1, 1, 2)],
    " in the first part and ",
    x@cohort_sizes[2],
    " ",
    label[ifelse(x@cohort_sizes[2] == 1, 1, 2)],
    " in the second.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeMax` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#'
#' @export
#' @method knit_print CohortSizeMax
#' @rdname knit_print
knit_print.CohortSizeMax <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  params <- list(...)
  params[["asis"]] <- asis
  rv <- paste0(
    "The maximum of the cohort sizes defined in the following rules:",
    paste0(
      lapply(
        x@cohort_sizes,
        function(x) {
          knit_print(x, ..., asis = asis)
        }
      ),
      collapse = "\n"
    ),
    "\n\n",
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeMin` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#'
#' @export
#' @method knit_print CohortSizeMin
#' @rdname knit_print
knit_print.CohortSizeMin <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  rv <- paste0(
    "The minimum of the cohort sizes defined in the following rules:",
    paste0(
      lapply(
        x@cohort_sizes,
        function(x, ...) {
          knit_print(x, asis = asis, ...)
        }
      ),
      collapse = "\n"
    ),
    "\n\n",
    sep = "\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeOrdinal` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` method of the standard rule
#'
#' @export
#' @method knit_print CohortSizeOrdinal
#' @rdname knit_print
knit_print.CohortSizeOrdinal <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  tox_label <- h_prepare_labels(tox_label)

  rv <- paste0(
    "Based on a ",
    tox_label[1],
    " grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
    "\n\n",
    sep = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @include helpers.R
#' @include McmcOptions-validity.R
#' @include CrmPackClass-class.R
NULL

# McmcOptions ----

## class ----

#' `McmcOptions`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`McmcOptions`] is a class for the three canonical MCMC options as well as
#' Random Number Generator settings.
#'
#' @slot iterations (`count`)\cr number of MCMC iterations.
#' @slot burnin (`count`)\cr number of burn-in iterations which are not saved.
#' @slot step (`count`)\cr only every `step`-th iteration is saved after
#'   the `burnin`. In other words, a sample from iteration
#'   `i = 1,...,iterations`, is saved if and only if
#'   `(i - burnin) mod step = 0`.\cr
#'   For example, for `iterations = 6`, `burnin = 0` and `step = 2`, only
#'   samples from iterations `2,4,6` will be saved.
#' @slot rng_kind (`string`)\cr a Random Number Generator (RNG) type used by
#'   [`rjags`]. It must be one out of the following four values:
#'   `base::Wichmann-Hill`, `base::Marsaglia-Multicarry`,
#'   `base::Super-Duper`, `base::Mersenne-Twister`, or `NA_character_`.
#'   If it is `NA_character_` (default), then the RNG kind will be chosen by
#'   [`rjags`].
#' @slot rng_seed (`number`)\cr a Random Number Generator (RNG) seed
#'   used by [`rjags`] for a chosen `rng_kind`. It must be an integer scalar or
#'   `NA_integer_`, which means that the seed will be chosen by [`rjags`].
#'
#' @aliases McmcOptions
#' @export
#'
.McmcOptions <- setClass(
  Class = "McmcOptions",
  slots = c(
    iterations = "integer",
    burnin = "integer",
    step = "integer",
    rng_kind = "character",
    rng_seed = "integer"
  ),
  prototype = prototype(
    iterations = 1000L,
    burnin = 100L,
    step = 2L,
    rng_kind = NA_character_,
    rng_seed = NA_integer_
  ),
  contains = "CrmPackClass",
  validity = v_mcmc_options
)

## constructor ----

#' @rdname McmcOptions-class
#'
#' @param burnin (`count`)\cr number of burn-in iterations which are not saved.
#' @param step (`count`)\cr only every step-th iteration is saved after
#'   the burn-in.
#' @param samples (`count`)\cr number of resulting samples.
#' @param rng_kind (`string`)\cr the name of the RNG type. Possible types are:
#'   `Wichmann-Hill`, `Marsaglia-Multicarry`, `Super-Duper`, `Mersenne-Twister`.
#'   If it is `NA` (default), then the RNG kind will be chosen by `[rjags`].
#' @param rng_seed (`number`)\cr RNG seed corresponding to chosen `rng_kind`.
#'   It must be an integer value or `NA` (default), which means that the seed
#'   will be chosen by `[rjags`].
#'
#' @export
#' @example examples/McmcOptions-class-McmcOptions.R
#'
McmcOptions <- function(
  burnin = 1e4L,
  step = 2L,
  samples = 1e4L,
  rng_kind = NA_character_,
  rng_seed = NA_integer_
) {
  assert_count(burnin, positive = TRUE)
  assert_count(step, positive = TRUE)
  assert_count(samples, positive = TRUE)
  assert_string(rng_kind, na.ok = TRUE)
  assert_count(rng_seed, na.ok = TRUE)

  if (!is.na(rng_kind)) {
    rng_kind <- paste0("base::", rng_kind)
  } else {
    rng_kind <- NA_character_
  }
  if (!is.na(rng_seed)) {
    rng_seed <- as.integer(rng_seed)
  } else {
    rng_seed <- NA_integer_
  }

  .McmcOptions(
    iterations = as.integer(burnin + (step * samples)),
    burnin = as.integer(burnin),
    step = as.integer(step),
    rng_kind = rng_kind,
    rng_seed = as.integer(rng_seed)
  )
}

## default constructor ----

#' @rdname McmcOptions-class
#' @note Typically, end users will not use the `.DefaultMcmcOptions()` function.
#' @export
.DefaultMcmcOptions <- function() {
  McmcOptions(
    burnin = 250,
    samples = 1000
  )
}

# tidy ----

## generic ----

#' Tidying `CrmPackClass` objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' In the spirit of the `broom` package, provide a method to convert a
#' `CrmPackClass` object to a (list of) tibbles.
#'
#' @param x (`CrmPackClass`)\cr the object to be tidied.
#' @param ... potentially used by class-specific methods
#'
#' @return A (list of) tibble(s) representing the object in tidy form.
#'
#' @export
#'
setGeneric(
  name = "tidy",
  def = function(x, ...) {
    standardGeneric("tidy")
  }
)

## CrmPackClass ----

#' Tidy a `CrmPackClass` Object
#'
#' Following the principles of the `broom` package, convert a `CrmPackClass`
#' object to a (list of) tibbles.  This is a basic, default representation.
#'
#' @param x (`CrmPackClass`)\cr the object to be tidied.
#' @param ... potentially used by class-specific methods.
#' @rdname tidy
#' @aliases tidy-CrmPackClass
#' @keywords methods
#' @example examples/CrmPackClass-method-tidy.R
#'
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CrmPackClass"),
  definition = function(x, ...) {
    rv <- h_tidy_all_slots(x) %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

#' Verbose Logging
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A family of wrappers of selected [`futile.logger`] functions that control
#' the logging mechanism in `crmPack`. The `crmPack` uses [`futile.logger`]
#' package for the logging purposes. All the messages logged in `crmPack` are
#' logged into `crmPack` logger at the [`futile.logger::TRACE`] level. Hence,
#' enabling verbose logging means that the logging threshold will be set to
#' [`futile.logger::TRACE`] for the `crmPack` logger, and disabling verbose
#' logging means that it will be set to [`futile.logger::FATAL`].
#'
#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.threshold()] that enables `crmPack` verbose logging by
#'   setting logging threshold to [`futile.logger::TRACE`] for `crmPack` logger.
#'
#' @export
#'
enable_logging <- function() {
  invisible(
    futile.logger::flog.threshold(futile.logger::TRACE, name = "crmPack")
  )
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.threshold()] that disables `crmPack` verbose logging
#'   by setting logging threshold to [`futile.logger::FATAL`] for `crmPack`
#'   logger.
#'
#' @export
#'
disable_logging <- function() {
  invisible(
    futile.logger::flog.threshold(futile.logger::FATAL, name = "crmPack")
  )
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.logger()] that checks whether current threshold level
#'   for `crmPack` logger is verbose, which is [`futile.logger::TRACE`].
#'   It returns `TRUE` if the current logging level is verbose, `FALSE`
#'   otherwise.
#'
#' @export
#'
is_logging_enabled <- function() {
  logger <- futile.logger::flog.logger(name = "crmPack")
  unname(logger$threshold == futile.logger::TRACE)
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.trace()] that prints a log message in the `crmPack`
#'   logger.
#'
#' @inheritParams futile.logger::flog.trace
#'
#' @export
#'
log_trace <- function(msg, ..., capture = FALSE) {
  assert_string(msg)
  assert_flag(capture)

  futile.logger::flog.trace(msg = msg, ..., name = "crmPack", capture = capture)
}

# v_mcmc_options ----

#' Internal Helper Functions for Validation of [`McmcOptions`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`McmcOptions`] or inherited classes and therefore not exported.
#'
#' @name v_mcmcoptions_objects
#' @param object (`McmcOptions`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_mcmcoptions_objects validates that the [`McmcOptions`]
#'   object contains valid integer scalars `iterations`, `burnin` and `step`
#'   as well as proper parameters for Random Number Generator.
v_mcmc_options <- function(object) {
  v <- Validate()
  allowed_rng_kinds <- c(
    "base::Wichmann-Hill",
    "base::Marsaglia-Multicarry",
    "base::Super-Duper",
    "base::Mersenne-Twister",
    NA_character_
  )

  v$check(
    test_int(object@iterations, lower = 1L),
    "iterations must be integer scalar greater than or equal to 1"
  )
  v$check(
    test_int(object@burnin, lower = 0L),
    "burn-in must be non-negative integer scalar"
  )
  # This below check should not be conducted in above test, using
  # `upper = object@iterations -1` argument, since object@iterations might be
  # not-valid. In such a case `test_int` throws an internal error.
  v$check(
    test_true(object@burnin < object@iterations),
    "burn-in must be lower than iterations"
  )
  v$check(
    test_int(object@step, lower = 1L),
    "step must be integer scalar greater than or equal to 1"
  )

  is_rng_kind_scalar <- test_string(object@rng_kind, na.ok = TRUE)
  v$check(is_rng_kind_scalar, "rng_kind must be a single string")
  v$check(
    test_subset(object@rng_kind, allowed_rng_kinds),
    paste0(
      "rng_kind must one of the following: ",
      paste(allowed_rng_kinds, collapse = ", "),
      ". User specifies the rng_kind without `base::` prefix"
    )
  )

  is_rng_seed_scalar <- test_int(object@rng_seed, na.ok = TRUE)
  v$check(is_rng_seed_scalar, "rng_seed must be an integer scalar")

  # Below `if` condition is not only reasonable but also needed as R CMD check
  # is activating some stricter checks and it fails when arguments to `||` are
  # not scalars, even if `||` works well with vectors of length > 1.
  if (is_rng_kind_scalar && is_rng_seed_scalar) {
    v$check(
      !is.na(object@rng_kind) || is.na(object@rng_seed),
      "rng_seed supplied but rng_kind not set"
    )
  }
  v$result()
}

#' Check That Labels Are Valid and Useful
#'
#' A vector of labels is valid and useful if it is of length 2, of type character
#' and its values are distinct.
#'
#' If `x` is a scalar, a second element is added, whose value is the value of the
#' scalar with "s" appended.  If `x` is `"toxicity"`, the plural is handled appropriately.
#'
#' @param x (`character`)\cr The vector to be checked
#' @keywords internal
#' @return a character vector of length 2 whose values are distinct
h_prepare_labels <- function(x) {
  assert_character(
    x,
    min.len = 1,
    max.len = 2,
    any.missing = FALSE,
    unique = TRUE
  )

  if (length(x) == 1) {
    if (x == "toxicity") {
      x <- c("toxicity", "toxicities")
    } else {
      x[2] <- paste0(x[1], "s")
    }
  }
  x
}

#' Append Units to a Numeric Dose
#'
#' @param units (`character`)\cr the units to be displayed
#' @keywords internal
#' @return if `units` is `NA`, then `NA`.  Otherwise, `units`, ensuring that exactly
#' one space precedes the first non-whitespace character
h_prepare_units <- function(units = NA) {
  assert_character(units, len = 1)

  ifelse(
    is.na(units),
    "",
    paste0(" ", stringr::str_trim(units, "left"))
  )
}

#' @include McmcOptions-class.R
NULL

# size ----

## generic ----

#' Size of an Object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that computes the size of a given object. This can be for instance
#' a size of a MCMC sample, or the size of a cohort. See the help of a specific
#' method for more details.
#'
#' @param object (`McmcOptions` or `Samples` or `CohortSize`)\cr an object
#'   for which the size is computed.
#' @param ... further arguments passed to `size` specific methods.
#'
#' @return A size of a given object.
#' @export
#'
setGeneric(
  name = "size",
  def = function(object, ...) {
    standardGeneric("size")
  },
  valueClass = "integer"
)

## McmcOptions ----

#' @describeIn size compute the number of MCMC samples based on `McmcOptions`
#'   object.
#' @aliases size-McmcOptions
#' @example examples/McmcOptions-methods-size.R
setMethod(
  f = "size",
  signature = signature(object = "McmcOptions"),
  definition = function(object, ...) {
    iterations_relative <- object@iterations - object@burnin
    if (iterations_relative <= 0) {
      return(0L)
    }
    as.integer(floor(iterations_relative / object@step))
  }
)

# saveSample ----

## generic ----

#' Determining if this Sample Should be Saved
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that determines if a sample from a given `iteration` should be
#' saved. The sample should be saved if and only if:
#' it is not in burn-in period and it matches the `step`.
#'
#' @param object (`McmcOptions`)\cr object based on which the answer is
#'   determined.
#' @param iteration (`count`)\cr the current iteration index.
#' @param ... not used.
#' @return `TRUE` if this sample should be saved.
#' @export
#'
setGeneric(
  name = "saveSample",
  def = function(object, iteration, ...) {
    standardGeneric("saveSample")
  },
  valueClass = "logical"
)

## McmcOptions ----

#' @describeIn saveSample determine if a sample should be saved.
#' @aliases saveSample-McmcOptions
#' @example examples/McmcOptions-methods-saveSample.R
setMethod(
  f = "saveSample",
  signature = signature(object = "McmcOptions"),
  definition = function(object, iteration, ...) {
    iteration_relative <- iteration - object@burnin
    iteration_relative > 0 && ((iteration_relative %% object@step) == 0)
  }
)

#' Convert a Samples Object from an ordinal Model to the Equivalent Samples Object
#' from a Binary Model
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that converts a [`Samples`] object from the fit of an
#' ordinal CRM model to that which would have been obtained from fitting a binary
#' CRM model for toxicities of a specified grade to the same observed data.
#'
#' @param obj (`Samples`)\cr the `Samples` object to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
#' is required.
#' @return A [`Samples`] object.
#'
#' @export
h_convert_ordinal_samples <- function(obj, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(obj, "Samples")
  assert_subset(c(paste0("alpha", 1:grade), "beta"), names(obj@data))
  # Execute
  d <- list(
    "alpha0" = obj@data[[paste0("alpha", grade)]],
    "alpha1" = obj@data$beta
  )
  Samples(data = d, options = obj@options)
}

# nolint start

#' Object-oriented implementation of CRM designs
#'
#' @name crmPack
#' @title Object-oriented implementation of CRM designs
#' @import checkmate
#' @import ggplot2
#' @import methods
#' @import tibble
#' @importFrom grid grid.draw
#' @importFrom gridExtra arrangeGrob
#' @importFrom graphics plot hist legend lines matlines matplot
#' @importFrom stats binomial coef cov2cor gaussian glm lm median model.matrix
#'   optim pgamma plogis pnorm qgamma qlogis qnorm quantile rbinom rgamma
#'   approxfun rnorm runif uniroot var vcov step mad pbeta dbeta dgamma
#'   setNames
#' @importFrom utils data head tail capture.output
#' @importFrom lifecycle badge
#' @importFrom rjags jags.model jags.samples
#' @importFrom futile.logger flog.threshold flog.logger flog.trace TRACE FATAL
#' @importFrom knitr knit_print
#' @importFrom kableExtra kbl add_header_above column_spec collapse_rows
#'   kable_styling add_footnote kable
#' @importFrom Rdpack reprompt
#'
#' @keywords package
#' @references \insertRef{SabanesBoveYeungPalermoJaki2019}{crmPack}
"_PACKAGE"

##' @keywords internal
.onAttach <- function(libname, pkgname) {
  packageStartupMessage(
    "Type crmPackHelp() to open help browser\n",
    "Type crmPackExample() to open example\n"
  )
}

## need to declare global variable / function
## names in order to avoid R CMD check notes:
globalVariables(c(
  "log.betaZ",
  "precW",
  "pow",
  "nObs",
  "betaZ",
  "x",
  "betaW",
  "xLevel",
  "precW",
  "z",
  "nGrid",
  "doseGrid",
  "betaWintercept",
  "delta",
  "deltaStart",
  "delta2",
  "Effsamples",
  "logit<-",
  "rho0",
  "alpha0",
  "delta0",
  "alpha1",
  "delta1",
  "inverse",
  "priorCov",
  "theta",
  "comp0",
  "w",
  "DLTs",
  "y",
  "group",
  "annotate",
  "probSamples",
  "prec",
  "nu",
  "samples",
  "Type",
  "patient",
  "toxicity",
  "ID",
  "biomarker",
  "traj",
  "Statistic",
  "perc",
  "..density..",
  "middle",
  "lower",
  "upper",
  "middleBiomarker",
  "lowerBiomarker",
  "upperBiomarker",
  "nObsshare",
  "xshare",
  "yshare",
  "thisProb.PL",
  "thisMeanEff.PL",
  "thisSize.PL",
  "probit<-",
  "refDose",
  "Tmax",
  "u",
  "eps",
  "h",
  "lambda",
  "cadj",
  "A",
  "lambda_p",
  "cond",
  "t0",
  "tend",
  "t0_case",
  "tend_case",
  "yhat",
  "ref_dose",
  "comp",
  "X",
  "skel_probs",
  "is_combo",
  "results",
  "k",
  "value",
  "Parameter",
  "intervals",
  "Group",
  "Tox",
  "MaxOverdoseProb",
  "DoseGrid",
  "NGrid",
  "NObs",
  "XLevel"
))

# nolint end

#' @include McmcOptions-methods.R
NULL

# v_samples ----

#' Internal Helper Functions for Validation of [`Samples`] Objects
#'
#' @description These functions are only used internally to validate the format
#'   of an input [`Samples`] or inherited classes and therefore not exported.
#'
#' @name v_samples_objects
#' @param object (`Samples`)\cr object to validate.
#' @return A `character` vector with the validation failure messages, or `TRUE`
#'   in case validation passes.
NULL

#' @describeIn v_samples_objects validates that the [`Samples`] object contains
#'   valid `data` slot.
v_samples <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@data, NROW) == size(object@options)),
    "Every element in data must be of the same length (no. of rows) as the sample size was"
  )
  v$check(
    all(sapply(object@data, test_numeric, finite = TRUE, any.missing = FALSE)),
    "Every element in data must be a finite object of type integer or double"
  )
  v$result()
}

#' @include McmcOptions-class.R
#' @include Samples-validity.R
#' @include CrmPackClass-class.R
NULL

# Samples ----

## class ----

#' `Samples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Samples`] is the class to store the MCMC samples.
#'
#' @slot data (`list`)\cr MCMC samples of the parameter. Each entry in this list
#'   must be a vector (in case of a scalar parameter) or matrix (in case of a
#'   vector-valued parameter) with samples.
#'   In case of matrix, every row is a separate sample, while columns correspond
#'   to the dimension of the parameter.
#' @slot options (`McmcOptions`)\cr MCMC options that were used to generate the
#'   samples.
#'
#' @aliases Samples
#' @export
#'
.Samples <- setClass(
  Class = "Samples",
  slots = c(
    data = "list",
    options = "McmcOptions"
  ),
  prototype = prototype(
    data = list(),
    options = McmcOptions()
  ),
  contains = "CrmPackClass",
  validity = v_samples
)

## constructor ----

#' @rdname Samples-class
#'
#' @param data see slot definition.
#' @param options see slot definition.
#'
#' @export
#' @example examples/Samples-class.R
#'
Samples <- function(data, options) {
  new("Samples", data = data, options = options)
}

## default constructor ----

#' @rdname Samples-class
#' @note Typically, end users will not use the `.DefaultSamples()` function.
#' @export
.DefaultSamples <- function() {
  mcmc(
    data = .DefaultData(),
    model = .DefaultLogisticLogNormal(),
    options = .DefaultMcmcOptions()
  )
}

1		#' Convert Object's Attributes to a Tibble
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' A helper function that interrogates an object to see if it has attributes
6		#' and, if so, converts them to a (list of) tibbles. Columns are named after
7		#' attributes. If attributes have different lengths but recycling is possible,
8		#' a single `tibble` is returned. Otherwise, a `list` of tibbles is returned.
9		#'
10		#' @param x (`CrmPackObject`)\cr object whose attributes will be interrogated.
11		#' @param .ignore (`character`)\cr names of attrributes to be ignored.
12		#'
13		#' @return A [`tibble`] or `list` of [`tibble`]s containg the values of the
14		#' object's attributes.
15		#'
16		#' @keywords internal
17		#' @noRd
18		h_handle_attributes <- function(
19		x,
20		.ignore = c("names", "class", "description", "row.names")
21		) {
22	2x	a <- attributes(x)
23	2x	valid_names <- setdiff(names(a), .ignore)
24	2x	lapply(
25	2x	valid_names,
26	2x	function(n) {
27	12x	z <- attr(x, n)
28	12x	rv <- NULL
29		# Some Design classes have attributes that are functions or CrmPackClass objects
30	12x	if (!is.function(z)) {
31	12x	if (length(z) == 1) {
32	12x	if (is(z, "CrmPackClass")) {
33	!	z <- z %>% tidy()
34		}
35	12x	rv <- tibble::tibble(X = z)
36		} else {
37	!	if (length(z) == 0) {
38	!	rv <- tibble::tibble(X = NA)
39		} else {
40	!	if (is(z, "CrmPackClass")) {
41	!	rv <- z %>% tidy()
42		} else {
43	!	rv <- tibble::tibble(X = list(z))
44		}
45		}
46		}
47	12x	names(rv) <- n
48		}
49	12x	rv
50		}
51		) %>%
52	2x	dplyr::bind_cols()
53		}
54
55		#' Tidy a Single Slot of a CrmPackObject
56		#'
57		#' @description `r lifecycle::badge("experimental")`
58		#'
59		#' A helper function that converts a single slot of a `CrmPackObject` to a tibble.
60		#' If the slots value is a `list`, each element of the list is tidied individually.
61		#'
62		#' @param obj (`CrmPackObject`)\cr object to be converted.
63		#' @param slot_name (`character`)\cr name of the slot to be tidied.
64		#' @param col (`character`)\cr The name of the corresponding column in the tidied
65		#' tibble. Defaults to `slot_name`.
66		#' @param attributes (`flag`)\cr shoud the object's attributes, if any, be added
67		#' to the output tibble
68		#'
69		#' @return A [`tibble`]
70		#'
71		#' @keywords internal
72		#' @importFrom rlang :=
73		#' @noRd
74		h_tidy_slot <- function(obj, slot_name, col = NULL, attributes = FALSE) {
75	1734x	if (is.list(slot(obj, slot_name))) {
76	56x	return(
77	56x	lapply(
78	56x	slot(obj, slot_name),
79	56x	function(x) {
80	106x	if (is.data.frame(x)) {
81	11x	x
82	56x	} else if (
83	95x	is.list(x) &&
84	95x	stringr::str_detect(class(x)[1], stringr::fixed("tbl_"))
85		) {
86		# Already tidied to a list.
87	!	x
88	95x	} else if (is.numeric(x) \| is.character(x)) {
89		# tidy.numeric & tidy.character are deprecated
90	6x	tibble::tibble(!!{{ slot_name }} := x)
91		} else {
92	89x	x %>% tidy()
93		}
94		}
95		)
96		)
97		}
98	1678x	if (is(slot(obj, slot_name), "CrmPackClass")) {
99	262x	rv <- slot(obj, slot_name) %>%
100	262x	tidy()
101		} else {
102	1416x	if (is.null(col)) {
103	1416x	col <- slot_name
104		}
105	1416x	rv <- tibble::tibble({{ col }} := slot(obj, slot_name))
106		}
107	1678x	if (attributes) {
108	!	a <- h_handle_attributes(slot(obj, slot_name))
109	!	if (nrow(a) > 0) {
110	!	rv <- rv %>% dplyr::bind_cols(a)
111		}
112		}
113	1678x	rv
114		}
115
116		#' Tidy All Slots of a CrmPackObject
117		#'
118		#' @description `r lifecycle::badge("experimental")`
119		#'
120		#' A helper function that converts all the slots of a `CrmPackObject` to a
121		#' (list of) tibble(s).
122		#'
123		#' @param obj (`CrmPackObject`)\cr object to be tidied.
124		#' @param ... passed to h_tidy_slot
125		#'
126		#' @return A (list of) [`tibble`](s)
127		#'
128		#' @keywords internal
129		#' @noRd
130		h_tidy_all_slots <- function(obj, ...) {
131	494x	slot_names <- slotNames(obj)
132	494x	rv <- list()
133	494x	for (nm in slot_names) {
134	1934x	if (!is.function(slot(obj, nm))) {
135	1678x	rv[[nm]] <- h_tidy_slot(obj, nm, ...)
136		}
137		}
138		# Column bind of all list elements have the same number of rows
139	494x	if (length(rv) > 1 && length(unique(sapply(rv, nrow))) == 1) {
140	228x	rv <- rv %>% dplyr::bind_cols() # nolint
141		}
142	494x	rv
143		}
144
145		#' Amend the Class of a Tibble to Indicate that it Contains a Tidied `CrmPackObject`
146		#'
147		#' @description `r lifecycle::badge("experimental")`
148		#'
149		#' A helper function that prepends `tbl_<cls>`, where `<cls>` is the first
150		#' element of the class attribute of the original `CrmPackObject` to the class
151		#' attribute of a tibble
152		#'
153		#' @param d (`tibble`)\cr the tibble containing the tidied version of `obj`.
154		#' @param obj (`CrmPackObject`)\cr object to be converted.
155		#'
156		#' @return `d`, with an amended class attribute
157		#'
158		#' @keywords internal
159		#' @noRd
160		h_tidy_class <- function(d, obj) {
161	784x	cls <- class(obj)
162	784x	class(d) <- c(paste0("tbl_", cls[1]), class(d))
163	784x	d
164		}
165
166		#' Convert a `CrmPackObject`'s "Interval list" to a Min-Max
167		#'
168		#' @description `r lifecycle::badge("experimental")`
169		#'
170		#' `CrmPackClass` objects that define a set of intervals (such as `CohortSizeRange`)
171		#' typically contain a left-open vector that dfines the intervals. For example,
172		#' `my_size <- CohortSizeRange(intervals = c(0, 20), cohort_size = c(1, 3))` defines
173		#' two dose ranges: [0, 20) and [20, Inf). This is convenient for coding, but
174		#' awkward for reporting. This helper function converts this single-column
175		#' representation to a two-column representation that explicitly defines the
176		#' lower and upper ends of each interval. Using the example above, the converted
177		#' tibble would look like this:
178		#'
179		#' \| cohort_size \| min \| max \|
180		#' \| ----------: \| ---: \| ---: \|
181		#' \| 1 \| -Inf \| 20 \|
182		#' \| 3 \| 20 \| Inf \|
183		#'
184		#' @param x (`tibble`)\cr the tibble to be converted.
185		#' @param col (`tidy-eval`)\cr column containing the intervals.
186		#' @param min_col (`character`)\cr name of the column containing the lower end
187		#' of the interval in the returned value.
188		#' @param max_col (`character`)\cr name of the column containing the upper end
189		#' of the interval in the returned value.
190		#' @param range_min (`numeric`)\cr value of the lower end of the first interval.
191		#' @param range_max (`numeric`)\cr value of the upper end of the last interval.
192		#'
193		#' @return A `tibble` in min-max format, with one row more than the input tibble.
194		#'
195		#' @importFrom rlang :=
196		#' @keywords internal
197		#' @noRd
198		h_range_to_minmax <- function(
199		x,
200		col,
201		min_col = "min",
202		max_col = "max",
203		range_min = -Inf,
204		range_max = Inf
205		) {
206	98x	vals <- x %>% dplyr::pull({{ col }})
207	98x	tibble(
208	98x	{{ min_col }} := c(range_min, vals),
209	98x	{{ max_col }} := c(vals, range_max)
210		)
211		}

1		# assertions ----
2
3		#' Additional Assertions for `checkmate`
4		#'
5		#' @description `r lifecycle::badge("experimental")`
6		#'
7		#' We provide additional assertion functions that can be used together with
8		#' the `checkmate` functions. These are described in individual help pages
9		#' linked below.
10		#'
11		#' @return Depending on the function prefix.
12		#' - `assert_` functions return the object invisibly if successful, and otherwise
13		#' throw an error message.
14		#' - `check_` functions return `TRUE` if successful, otherwise a string with the
15		#' error message.
16		#' - `test_` functions just return `TRUE` or `FALSE`.
17		#'
18		#' @seealso [assert_probabilities()], [assert_probability()],
19		#' [assert_probability_range()], [assert_length()].
20		#'
21		#' @name assertions
22		NULL
23
24		# check equality ----
25
26		#' Check if All Arguments Are Equal
27		#'
28		#' @description `r lifecycle::badge("experimental")`
29		#' Elements of `...` must be numeric vectors or scalars.
30		#'
31		#' This function performs an element-by-element comparison of the first object
32		#' provided in `...` with every other object in `...` and returns `TRUE` if all
33		#' comparisons are equal within a given tolerance and `FALSE` otherwise.
34		#'
35		#' @param ... (`numeric`)\cr vectors to be compared.
36		#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
37		#' judging equality.
38		#'
39		#' @note If there are any missing or infinite values in `...`, this function
40		#' returns `FALSE`, regardless of the values of other elements in `...`.
41		#'
42		#' @note If elements in `...` are not all of the same length, `FALSE` is returned.
43		#'
44		#' @return `TRUE` if all element-by-element differences are less than `tolerance`
45		#' in magnitude, `FALSE` otherwise.
46		#' @seealso [`assertions`] for more details.
47		#'
48		#' @export
49		#' @examples
50		#' check_equal(1:2, 1:2) # TRUE
51		#' check_equal(1:2, 2:3) # "Not all equal"
52		#' check_equal(Inf, Inf) # "Not all equal"
53		#' check_equal(0.01, 0.02) # "Not all equal"
54		#' check_equal(0.01, 0.02, tol = 0.05) # TRUE
55		#' check_equal(1, c(1, 1)) # "Not all equal"
56		check_equal <- function(..., tol = sqrt(.Machine$double.eps)) {
57	14x	dot_args <- list(...)
58
59	14x	sapply(dot_args, assert_numeric)
60
61	14x	tmp <- sapply(dot_args, length)
62	14x	if (min(tmp) != max(tmp)) {
63	2x	return("Not all of same length")
64		}
65	12x	if (any(sapply(dot_args, is.na))) {
66	2x	return("Some entries NA")
67		}
68	10x	if (any(sapply(dot_args, is.infinite))) {
69	2x	return("Not all entries finite")
70		}
71	8x	if (!all(sapply(dot_args, test_numeric))) {
72	!	return("Not all numeric")
73		}
74
75	8x	all_ok <- test_true(
76	8x	all(
77	8x	sapply(
78	8x	2:length(dot_args),
79	8x	function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol
80		)
81		)
82		)
83	8x	if (all_ok) {
84	4x	return(TRUE)
85		}
86	4x	"Not all equal"
87		}
88
89		#' Assert That All Arguments Are Equal
90		#'
91		#' @description `r lifecycle::badge("experimental")`
92		#' Elements of `...` must be numeric vectors or scalars.
93		#'
94		#' This function performs an element-by-element comparison of the first object
95		#' provided in `...` with every other object in `...` and throws an error if they
96		#' are not.
97		#'
98		#' @param ... (`numeric`)\cr vectors to be compared
99		#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
100		#' judging equality
101		#'
102		#' @note If there are any missing or infinite values in `...`, this function
103		#' throws an error, regardless of the values of other elements in `...`.
104		#'
105		#' @note If elements in `...` are not all of the same length, an error is thrown.
106		#'
107		#' @return `list(...)`, invisibly.
108		#' @seealso [`assertions`] for more details.
109		#' @inheritParams checkmate::assert_numeric
110		#'
111		#' @export
112		#' @rdname check_equal
113		#' @examples
114		#' assert_equal(1:2, 1:2) # no error
115		#' assert_equal(0.01, 0.02, tol = 0.05) # no error
116		# nolint start
117		assert_equal <- function(
118		...,
119		tol = sqrt(.Machine$double.eps),
120		.var.name = vname(x),
121		add = NULL
122		) {
123		# assert_equal <- makeAssertionFunction(check_equal) fails with error "Error
124		# in `checkmate::makeAssertion(..., res, .var.name, add)`: unused argument
125		# (add)", possibly because of the use of ... in check_equal.
126	7x	res <- check_equal(..., tol = tol)
127	7x	makeAssertion(list(...), res, .var.name, add)
128		}
129		# nolint end
130
131		# assert_probabilities ----
132
133		#' Check if an argument is a probability vector
134		#'
135		#' @description `r lifecycle::badge("stable")`
136		#'
137		#' Check if every element in a given numerical vector or matrix represents a
138		#' probability, that is a number within (0, 1) interval, that can optionally be
139		#' closed at any side.
140		#'
141		#' @note If there are any missing or non-finite values in `x`, this function
142		#' returns `FALSE`, regardless of the values of other elements in `x`.
143		#'
144		#' @param x (`numeric`)\cr vector or matrix with numerical values to check.
145		#' @param bounds_closed (`logical`)\cr should bounds be closed? This can be a
146		#' scalar or vector of length two. If it is a scalar, then its value applies
147		#' equally to lower bound \eqn{0} and upper bound \eqn{1}. If this is a vector
148		#' with two flags, the first flag corresponds to the lower bound \eqn{0}
149		#' only, and the second to the upper bound \eqn{1} only.
150		#' @inheritParams checkmate::check_numeric
151		#'
152		#' @return `TRUE` if successful, otherwise a string with the error message.
153		#'
154		#' @seealso [`assertions`] for more details.
155		#'
156		#' @export
157		#' @examples
158		#' x <- c(0, 0.2, 0.1, 0.3, 1)
159		#' check_probabilities(x)
160		#' check_probabilities(x, bounds_closed = FALSE)
161		#' check_probabilities(x, bounds_closed = c(FALSE, TRUE))
162		check_probabilities <- function(
163		x,
164		bounds_closed = TRUE,
165		len = NULL,
166		unique = FALSE,
167		sorted = FALSE
168		) {
169	1965x	assert_numeric(x)
170	1965x	assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)
171	1965x	assert_number(len, null.ok = TRUE)
172	1965x	assert_flag(sorted)
173
174	1965x	result <- check_numeric(
175	1965x	x,
176	1965x	finite = TRUE,
177	1965x	any.missing = FALSE,
178	1965x	len = len,
179	1965x	unique = unique,
180	1965x	sorted = sorted
181		)
182
183	1965x	if (isTRUE(result)) {
184	1893x	in_bounds <- all(h_in_range(
185	1893x	x,
186	1893x	range = c(0L, 1L),
187	1893x	bounds_closed = bounds_closed
188		))
189	1893x	if (!in_bounds) {
190	136x	result <- paste(
191	136x	"Probability must be within",
192	136x	ifelse(bounds_closed[1], "[0,", "(0,"),
193	136x	ifelse(tail(bounds_closed, 1), "1]", "1)"),
194	136x	"bounds but it is not"
195		)
196		}
197		}
198
199	1965x	result
200		}
201
202		#' @rdname check_probabilities
203		#' @inheritParams check_probabilities
204		#' @export
205		assert_probabilities <- makeAssertionFunction(check_probabilities)
206
207		#' @rdname check_probabilities
208		#' @inheritParams check_probabilities
209		#' @export
210		test_probabilities <- makeTestFunction(check_probabilities)
211
212		#' @rdname check_probabilities
213		#' @inheritParams check_probabilities
214		#' @export
215		expect_probabilities <- makeExpectationFunction(check_probabilities)
216
217		# assert_probability ----
218
219		#' Check if an argument is a single probability value
220		#'
221		#' @description `r lifecycle::badge("stable")`
222		#'
223		#' Check if a given value represents a probability, that is a number within
224		#' (0, 1) interval, that can optionally be closed at any side.
225		#'
226		#' @param x (`number`)\cr a single value to check.
227		#' @inheritParams check_probabilities
228		#'
229		#' @return `TRUE` if successful, otherwise a string with the error message.
230		#'
231		#' @seealso [`assertions`] for more details.
232		#'
233		#' @export
234		#' @examples
235		#' check_probability(0.5)
236		#' check_probability(0, bounds_closed = FALSE)
237		#' check_probability(0, bounds_closed = c(FALSE, TRUE))
238		check_probability <- function(x, bounds_closed = TRUE) {
239	1084x	check_probabilities(x = x, bounds_closed = bounds_closed, len = 1)
240		}
241
242		#' @rdname check_probability
243		#' @inheritParams check_probability
244		#' @export
245		assert_probability <- makeAssertionFunction(check_probability)
246
247		#' @rdname check_probability
248		#' @inheritParams check_probability
249		#' @export
250		test_probability <- makeTestFunction(check_probability)
251
252		#' @rdname check_probability
253		#' @inheritParams check_probability
254		#' @export
255		expect_probability <- makeExpectationFunction(check_probability)
256
257		# assert_probability_range ----
258
259		#' Check if an argument is a probability range
260		#'
261		#' @description `r lifecycle::badge("stable")`
262		#'
263		#' Check if a given numerical interval represents a probability range, that is
264		#' a sub-interval of (0, 1) interval, that can optionally be closed at any side.
265		#'
266		#' @param x (`number`)\cr an interval to check.
267		#' @inheritParams check_probabilities
268		#'
269		#' @return `TRUE` if successful, otherwise a string with the error message.
270		#'
271		#' @seealso [`assertions`] for more details.
272		#'
273		#' @export
274		#' @examples
275		#' x <- c(0, 0.2)
276		#' check_probability_range(x)
277		#' check_probability_range(rev(x))
278		#' check_probability_range(x, bounds_closed = FALSE)
279		#' check_probability_range(x, bounds_closed = c(FALSE, TRUE))
280		check_probability_range <- function(x, bounds_closed = TRUE) {
281	492x	check_probabilities(
282	492x	x = x,
283	492x	bounds_closed = bounds_closed,
284	492x	len = 2,
285	492x	sorted = TRUE
286		)
287		}
288
289		#' @rdname check_probability_range
290		#' @inheritParams check_probability_range
291		#' @export
292		assert_probability_range <- makeAssertionFunction(check_probability_range)
293
294		#' @rdname check_probability_range
295		#' @inheritParams check_probability_range
296		#' @export
297		test_probability_range <- makeTestFunction(check_probability_range)
298
299		#' @rdname check_probability_range
300		#' @inheritParams check_probability_range
301		#' @export
302		expect_probability_range <- makeExpectationFunction(check_probability_range)
303
304		# assert_length ----
305
306		#' Check if vectors are of compatible lengths
307		#'
308		#' @description `r lifecycle::badge("stable")`
309		#'
310		#' Two vectors are of compatible size if and only if: \cr
311		#' 1. At least one vector has size 1 \cr
312		#' 2. or both vectors are of the same size. \cr
313		#'
314		#' @param x (`any`)\cr the first vector, any object for which [length()]
315		#' function is defined.
316		#' @param len (`count`)\cr the length of the second vector.
317		#' @inheritParams checkmate::check_numeric
318		#'
319		#' @return `TRUE` if successful, otherwise a string with the error message.
320		#'
321		#' @seealso [`assertions`] for more details.
322		#'
323		#' @export
324		#' @examples
325		#' check_length(1:5, 1)
326		#' check_length(1:5, 6)
327		#' check_length(1:5, 5)
328		#' check_length(10, 1)
329		#' check_length(10, 9)
330		check_length <- function(x, len) {
331	479x	x_len <- length(x)
332	479x	assert_true(x_len >= 1L)
333	478x	assert_count(len)
334
335	474x	if (x_len == 1L \|\| len == 1L \|\| x_len == len) {
336	445x	TRUE
337		} else {
338	29x	paste(
339	29x	"x is of length",
340	29x	x_len,
341	29x	"which is not allowed; the allowed lengths are: 1 or",
342	29x	len,
343	29x	collapse = ""
344		)
345		}
346		}
347
348		#' @rdname check_length
349		#' @inheritParams check_length
350		#' @export
351		assert_length <- makeAssertionFunction(check_length)
352
353		#' @rdname check_length
354		#' @inheritParams check_length
355		#' @export
356		test_length <- makeTestFunction(check_length)
357
358		# assert_range ----
359
360		#' Check that an argument is a numerical range
361		#'
362		#' @description `r lifecycle::badge("stable")`
363		#'
364		#' An argument `x` is a numerical range if and only if (all conditions must be met):
365		#' 1. Is an object of type: `integer` or `double`.
366		#' 2. Is a vector or length two such that the value of the first number is not
367		#' less than the second number. Equalness is allowed if and only if `unique` flag
368		#' is set to `TRUE`.
369		#' 3. Lower bound of the interval is greater than or equal to `lower` and
370		#' upper bound of the interval is less than or equal to `upper`.
371		#' 4. It contains only finite (given that `finite` is `TRUE`) and non-missing values.
372		#'
373		#' @inheritParams checkmate::check_numeric
374		#'
375		#' @return `TRUE` if successful, otherwise a string with the error message.
376		#'
377		#' @seealso [`assertions`] for more details.
378		#'
379		#' @export
380		#' @examples
381		#' check_range(c(1, 5))
382		#' check_range(c(-5, 1))
383		#' check_range(c(4, 1))
384		#' check_range(c(1, 1))
385		#' check_range(c(1, 1), unique = FALSE)
386		#' check_range(1:3)
387		check_range <- function(
388		x,
389		lower = -Inf,
390		upper = Inf,
391		finite = FALSE,
392		unique = TRUE
393		) {
394	67x	assert_number(lower)
395	66x	assert_number(upper)
396	65x	assert_flag(finite)
397	64x	assert_flag(unique)
398
399	63x	result <- check_numeric(
400	63x	x,
401	63x	lower = lower,
402	63x	upper = upper,
403	63x	finite = finite,
404	63x	any.missing = FALSE,
405	63x	len = 2,
406	63x	unique = unique,
407	63x	sorted = TRUE
408		)
409
410	63x	if (!isTRUE(result)) {
411	24x	result <- paste("x must be a valid numerical range.", result)
412		}
413	63x	result
414		}
415
416		#' @rdname check_range
417		#' @inheritParams check_range
418		#' @export
419		assert_range <- makeAssertionFunction(check_range)
420
421		#' @rdname check_range
422		#' @inheritParams check_range
423		#' @export
424		test_range <- makeTestFunction(check_range)
425
426		#' @rdname check_range
427		#' @inheritParams check_range
428		#' @export
429		expect_range <- makeExpectationFunction(check_range)
430
431		# assert_format ----
432
433		#' Check that an argument is a valid format specification
434		#'
435		#' @description `r lifecycle::badge("stable")`
436		#'
437		#' @inheritParams checkmate::check_numeric
438		#'
439		#' @return `TRUE` if successful, otherwise a string with the error message.
440		#'
441		#' @seealso [`assertions`] for more details.
442		#'
443		#' @export
444		#' @examples
445		#' check_format("%5.2f")
446		check_format <- function(x, len = NULL, min.len = NULL, max.len = NULL) {
447	24x	assert_number(len, lower = 1, null.ok = TRUE)
448	24x	assert_number(min.len, lower = 1, null.ok = TRUE)
449	24x	assert_number(max.len, lower = 1, null.ok = TRUE)
450
451	24x	result <- check_character(
452	24x	x,
453	24x	len = len,
454	24x	min.len = min.len,
455	24x	max.len = max.len,
456	24x	any.missing = FALSE,
457		# https://stackoverflow.com/questions/446285/validate-sprintf-format-from-input-field-with-regex
458	24x	pattern = "%(?:\\d+\\$)?[+-]?(?:[ 0]\|'.{1})?-?\\d*(?:\\.\\d+)?[bcdeEufFgGosxX]",
459		)
460
461	24x	if (!isTRUE(result)) {
462	!	result <- paste("x must be a valid format specifier.", result)
463		}
464	24x	result
465		}
466
467		#' @rdname check_format
468		#' @inheritParams check_format
469		#' @export
470		assert_format <- makeAssertionFunction(check_format)
471
472		#' @rdname check_format
473		#' @inheritParams check_format
474		#' @export
475		test_format <- makeTestFunction(check_format)
476
477		#' @rdname check_format
478		#' @inheritParams check_format
479		#' @export
480		expect_format <- makeExpectationFunction(check_format)

1		#' Apply a Function to Subsets of Data Frame.
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' `dapply` splits the data `df` into the subsets defined by `f`,
6		#' and applies function `FUN` to each of the subset.
7		#' All the results are row-binded and returned as `data.frame` object.
8		#'
9		#' @param df (`data frame`)\cr data set to be divided into groups.
10		#' @param f (`factor` or `formula` or `list`)\cr a factor in the sense that
11		#' `as.factor(f)` defines the grouping, or a `list` of such factors in which
12		#' case their interaction is used for the grouping. `f` can also be a formula
13		#' of the form `~ g1 + ... + gk` to split by the interaction of the variables
14		#' `g1, ..., gk`. This parameter is passed directly into [split()] function.
15		#' @param FUN (`function`)\cr the function to be applied to each subset of `df`
16		#' defined by `f`.
17		#' @param ... parameters passed to [lapply()], which is used when applying a
18		#' function `FUN` over groups defined by `f`.
19		#'
20		#' @return The [`data.frame`] object with results from `FUN`.
21		#'
22		#' @export
23		#' @example examples/utils-dapply.R
24		#'
25		dapply <- function(df, f, FUN, ...) {
26	11x	assert_data_frame(df)
27
28	11x	list_df <- split(df, f = f)
29	11x	list_df <- lapply(list_df, FUN, ...)
30	11x	df2 <- do.call(rbind, list_df)
31	11x	rownames(df2) <- NULL
32	11x	df2
33		}

1		#' Format a `doseGrid` for Printing
2		#'
3		#' @param grid (`numeric`)\cr the dose grid
4		#' @param units (`character`)\cr The units in which the values in `doseGrid` are
5		#' @param fmt (`character`)\cr The format used to display values in `doseGrid`.
6		#' If `NA`, grid values are not pre-formatted
7		#' @param ... not used at present
8		#' measured. Appended to each value in `doseGrid` when `knit_print`ed. The
9		#' default, `NA`, omits the units.
10		#' @return A character string containing the formatted dose grid. If the grid
11		#' is `c(1, 2, 3)` and `units` is `"mg"`, the returned value is `"1 mg, 2 mg and 3 mg"`.
12		#' @keywords internal
13		h_get_formatted_dosegrid <- function(grid, units = NA, fmt = NA, ...) {
14	16x	assert_numeric(
15	16x	grid,
16	16x	lower = 0,
17	16x	min.len = 2,
18	16x	unique = TRUE,
19	16x	finite = TRUE,
20	16x	sorted = TRUE,
21	16x	any.missing = FALSE
22		)
23	16x	assert_character(units, len = 1)
24
25	16x	n <- length(grid)
26	16x	units <- h_prepare_units(units)
27	16x	formattedGrid <- if (is.na(fmt)) {
28	16x	as.character(grid)
29		} else {
30	!	sprintf(fmt, grid)
31		}
32	16x	paste0(
33	16x	paste(
34	16x	lapply(
35	16x	formattedGrid[1:(n - 1)],
36	16x	paste0,
37	16x	sep = units
38		),
39	16x	collapse = ", "
40		),
41	16x	" and ",
42	16x	formattedGrid[n],
43	16x	paste0(units, ".\n\n")
44		)
45		}
46
47		#' Set Column Headers in Custom `knit_print` Methods
48		#'
49		#' This is a helper method used `knit_print` for `crmPack` classes.
50		#'
51		#' @param x (`ANY`)\cr object that will be printed
52		#' @param param (`list`)\cr A list of the `...` parameters passed to `knit_print`
53		#' @param summarise (`flag`)\cr Is the object to be summarised (default) or listed?
54		#' @return A character vector of column names.
55		#' @noRd
56		h_knit_print_set_headers <- function(x, param, summarise, ...) {
57	16x	UseMethod("h_knit_print_set_headers")
58		}
59
60		#' @description `r lifecycle::badge("experimental")`
61		#' @rdname knit_print_set_headers
62		#' @noRd
63		h_knit_print_set_headers.GeneralData <- function(x, param, summarise, ...) {
64	6x	if (!("col.names" %in% names(param))) {
65	6x	if (summarise == "none") {
66	6x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "DLT?")
67	!	} else if (summarise == "dose") {
68	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
69		} else {
70	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
71		}
72		}
73	6x	param
74		}
75
76		#' @description `r lifecycle::badge("experimental")`
77		#' @rdname knit_print_set_headers
78		#' @noRd
79		h_knit_print_set_headers.DataDA <- function(x, param, summarise, ...) {
80	2x	if (!("col.names" %in% names(param))) {
81	2x	if (summarise == "none") {
82	2x	param[["col.names"]] <- c(
83	2x	"ID",
84	2x	"Cohort",
85	2x	"Dose",
86	2x	"Tox",
87	2x	"U",
88	2x	"T0",
89	2x	"TMax"
90		)
91	!	} else if (summarise == "dose") {
92	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
93		} else {
94	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
95		}
96		}
97	2x	param
98		}
99
100		#' @description `r lifecycle::badge("experimental")`
101		#' @rdname knit_print_set_headers
102		#' @noRd
103		h_knit_print_set_headers.DataGrouped <- function(x, param, summarise, ...) {
104	!	if (!("col.names" %in% names(param))) {
105	!	if (summarise == "none") {
106	!	param[["col.names"]] <- c("ID", "Cohort", "Dose", "Group", "Tox")
107	!	} else if (summarise == "dose") {
108	!	param[["col.names"]] <- c("Dose", "Group", "Evaluable", "With Toxicities")
109		} else {
110	!	param[["col.names"]] <- c(
111	!	"Cohort",
112	!	"Group",
113	!	"Evaluable",
114	!	"With Toxicities"
115		)
116		}
117		}
118	!	param
119		}
120
121		#' @description `r lifecycle::badge("experimental")`
122		#' @rdname knit_print_set_headers
123		#' @noRd
124		h_knit_print_set_headers.DataParts <- function(x, param, summarise, ...) {
125	!	if (!("col.names" %in% names(param))) {
126	!	if (summarise == "none") {
127	!	param[["col.names"]] <- c("ID", "Part", "Cohort", "Dose", "Tox")
128	!	} else if (summarise == "dose") {
129	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
130		} else {
131	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
132		}
133		}
134	!	param
135		}
136
137		#' @description `r lifecycle::badge("experimental")`
138		#' @noRd
139		h_knit_print_set_headers.DataOrdinal <- function(x, param, summarise, ...) {
140	2x	if (!("col.names" %in% names(param))) {
141	2x	if (summarise == "none") {
142	2x	param[["col.names"]] <- c(
143	2x	"ID",
144	2x	"Cohort",
145	2x	"Dose",
146	2x	paste0("Cat", 0:(length(x@yCategories) - 1))
147		)
148	!	} else if (summarise == "dose") {
149	!	param[["col.names"]] <- c("Dose", "Evaluable", names(x@yCategories))
150		} else {
151	!	param[["col.names"]] <- c("Cohort", "Evaluable", names(x@yCategories))
152		}
153		}
154	2x	param
155		}
156
157		#' @description `r lifecycle::badge("experimental")`
158		#' @rdname knit_print_set_headers
159		#' @noRd
160		h_knit_print_set_headers.DataDual <- function(x, param, summarise, ...) {
161	6x	if (!("col.names" %in% names(param))) {
162	6x	if (summarise == "none") {
163	6x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "Tox", "W")
164	!	} else if (summarise == "dose") {
165	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
166		} else {
167	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
168		}
169		}
170	6x	param
171		}
172
173		#' Select Columns to Print in Custom `knit_print` Methods
174		#'
175		#' This is a helper method used `knit_print` for `crmPack` classes.
176		#'
177		#' @param x (`ANY`)\cr object that will be printed
178		#' @param ... Not used at present.
179		#' @return A tidied version of `x`, containing only the selected columns.
180		#' @noRd
181		h_knit_print_select_columns <- function(x, ...) {
182	16x	UseMethod("h_knit_print_select_columns")
183		}
184
185		#' @description `r lifecycle::badge("experimental")`
186		#' @rdname knit_print_select_columns
187		#' @noRd
188		h_knit_print_select_columns.GeneralData <- function(x, ...) {
189	!	x %>%
190	!	tidy() %>%
191	!	dplyr::select("ID", "Cohort", "Dose", "Tox")
192		}
193
194		#' @description `r lifecycle::badge("experimental")`
195		#' @rdname knit_print_select_columns
196		#' @noRd
197		h_knit_print_select_columns.Data <- function(x, ...) {
198	6x	x %>%
199	6x	tidy() %>%
200	6x	dplyr::select("ID", "Cohort", "Dose", "Tox")
201		}
202
203		#' @description `r lifecycle::badge("experimental")`
204		#' @rdname knit_print_select_columns
205		#' @noRd
206		h_knit_print_select_columns.DataParts <- function(x, ...) {
207	!	x %>%
208	!	tidy() %>%
209	!	dplyr::select("ID", "Part", "Cohort", "Dose", "Tox")
210		}
211
212		#' @description `r lifecycle::badge("experimental")`
213		#' @rdname knit_print_select_columns
214		#' @noRd
215		h_knit_print_select_columns.DataOrdinal <- function(x, ...) {
216	2x	x %>%
217	2x	tidy() %>%
218	2x	dplyr::select("ID", "Cohort", "Dose", tidyselect::starts_with("Cat"))
219		}
220
221		#' @description `r lifecycle::badge("experimental")`
222		#' @rdname knit_print_select_columns
223		#' @noRd
224		h_knit_print_select_columns.DataDA <- function(x, param, summarise, ...) {
225	2x	x %>%
226	2x	tidy() %>%
227	2x	dplyr::select("ID", "Cohort", "Dose", "Tox", "U", "T0", "TMax")
228		}
229
230		#' @description `r lifecycle::badge("experimental")`
231		#' @rdname knit_print_select_columns
232		#' @noRd
233		h_knit_print_select_columns.DataGrouped <- function(x, param, summarise, ...) {
234	!	x %>%
235	!	tidy() %>%
236	!	dplyr::select("ID", "Cohort", "Dose", "Group", "Tox")
237		}
238
239		#' @description `r lifecycle::badge("experimental")`
240		#' @rdname knit_print_select_columns
241		#' @noRd
242		h_knit_print_select_columns.DataDual <- function(x, param, summarise, ...) {
243	6x	x %>%
244	6x	tidy() %>%
245	6x	dplyr::select("ID", "Cohort", "Dose", "Tox", "W")
246		}
247
248		#' Summarise a `Data` Object by Dose or Cohort for Display in Custom `knit_print` Methods
249		#'
250		#' This is a helper method used `knit_print` for `crmPack` classes.
251		#'
252		#' @param x (`ANY`)\cr object that will be printed
253		#' @param full_grid (`flag`)\cr Should the full grid be included or only those
254		#' doses with at least one evaluable participant?
255		#' @param ... Not used at present.
256		#' @return A tibble containing the summarised data
257		#' @noRd
258		h_knit_print_summarise <- function(x, summarise, full_grid, ...) {
259	!	UseMethod("h_knit_print_summarise")
260		}
261
262		#' @description `r lifecycle::badge("experimental")`
263		#' @rdname knit_print_summarise
264		#' @noRd
265		h_knit_print_summarise.GeneralData <- function(x, summarise, full_grid, ...) {
266	!	xTidy <- x %>% tidy()
267	!	xTidy <- xTidy %>%
268	!	dplyr::group_by(.data[[stringr::str_to_title(summarise)]]) %>%
269	!	dplyr::summarise(
270	!	N = dplyr::n(),
271	!	ToxCount = sum(Tox)
272		)
273	!	if (full_grid && summarise == "dose") {
274	!	xTidy <- xTidy %>%
275	!	tidyr::complete(
276	!	Dose = x@doseGrid,
277	!	fill = list(ToxCount = 0, N = 0)
278		)
279		}
280	!	xTidy
281		}
282
283		#' @description `r lifecycle::badge("experimental")`
284		#' @rdname knit_print_summarise
285		#' @noRd
286		h_knit_print_summarise.DataOrdinal <- function(x, summarise, full_grid, ...) {
287	!	xTidy <- x %>% tidy()
288	!	xTidy <- xTidy %>%
289	!	dplyr::group_by(.data$Dose) %>%
290	!	dplyr::summarise(
291	!	N = dplyr::n(),
292	!	dplyr::across(tidyselect::starts_with("Cat"), sum)
293		)
294	!	if (full_grid && summarise == "dose") {
295	!	replace_list <- as.list(
296	!	c(
297	!	"N",
298	!	names(xTidy)[which(stringr::str_detect(names(xTidy), "Cat\\d+"))]
299		)
300		)
301		# Create a list whose names are the columns in which we need to replace NAs
302		# and whose values are 0
303	!	names(replace_list) <- sapply(replace_list, \(x) x)
304	!	replace_list <- lapply(replace_list, \(x) 0)
305		# Expand the tibble and do the replacement
306	!	xTidy <- tidyr::expand_grid(Dose = x@doseGrid) %>%
307	!	dplyr::left_join(xTidy, by = "Dose") %>%
308	!	tidyr::replace_na(replace_list)
309		}
310	!	xTidy
311		}
312
313		#' @description `r lifecycle::badge("experimental")`
314		#' @rdname knit_print_summarise
315		#' @noRd
316		h_knit_print_summarise.DataGrouped <- function(x, summarise, full_grid, ...) {
317	!	xTidy <- x %>% tidy()
318	!	xTidy <- xTidy %>%
319	!	dplyr::group_by(.data[[stringr::str_to_title(summarise)]], .data$Group) %>%
320	!	dplyr::summarise(
321	!	N = dplyr::n(),
322	!	ToxCount = sum(Tox)
323		)
324	!	if (full_grid && summarise == "dose") {
325	!	xTidy <- tidyr::expand_grid(
326	!	Dose = x@doseGrid,
327	!	Group = c("mono", "combo")
328		) %>%
329	!	dplyr::left_join(xTidy, by = c("Dose", "Group")) %>%
330	!	tidyr::replace_na(list(N = 0, ToxCount = 0))
331		}
332	!	xTidy
333		}
334
335		#' Print a `GeneralData` Object in a Markdown or Quarto Chunk
336		#'
337		#' @param label (`character`)\cr How to describe the participants in the trial.
338		#' See Usage Notes below.
339		#' @param full_grid (`flag`)\cr Should the full dose grid appear in the output table
340		#' or simply those doses for whom at least one evaluable participant is available?
341		#' Ignored unless `summarise == "dose"`.
342		#' @param summarise (`character`)\cr How to summarise the observed data. The default,
343		#' `"none"`, lists observed data at the participant level. `"dose"` presents
344		#' participant counts by dose and `"cohort"` by cohort.
345		#' @param summarize (`character`)\cr Synonym for `summarise`
346		#' @param format_func (`function`)\cr The function used to format the participant table.
347		#' The default applies no formatting. Obvious alternatives include `kableExtra::kable_styling`.
348		#' @param ... passed to [knitr::kable()]
349		#' @section Usage Notes:
350		#' `label` describes the trial's participants.
351		#'
352		#' It should be a character vector of length 1 or 2. If of length 2, the first
353		#' element describes a single participant and the second describes all other
354		#' situations. If of length 1, the character `s` is appended to the value
355		#' when the number of participants is not 1.
356		#' The default values of `col.names` and `caption` vary depending on the summary
357		#' requested. The default values can be overridden by passing `col.names` and
358		#' `caption` in the function call.
359		#'
360		#' @inheritParams h_get_formatted_dosegrid
361		#' @export
362		#' @method knit_print GeneralData
363		#' @rdname knit_print
364		knit_print.GeneralData <- function(
365		x,
366		...,
367		asis = TRUE,
368		label = c("participant", "participants"),
369		full_grid = FALSE,
370		summarise = c("none", "dose", "cohort"),
371		summarize = summarise,
372		units = NA,
373		format_func = h_knit_format_func
374		) {
375		# Validate
376	16x	assert_flag(asis)
377	16x	assert_flag(full_grid)
378	16x	assert_function(format_func)
379	16x	summarise <- match.arg(summarise)
380	16x	summarize <- match.arg(summarize)
381
382	16x	if (is.na(summarise) \|\| is.null(summarise)) {
383	!	summarise <- summarize
384		}
385	16x	assert_choice(summarise, c("none", "dose", "cohort"))
386		# Initialise
387	16x	label <- h_prepare_labels(label)
388	16x	param <- list(...)
389
390		# Execute
391	16x	param <- h_knit_print_set_headers(x, param, summarise, ...)
392	16x	if (summarise == "none") {
393	16x	if (!("caption" %in% names(param))) {
394	16x	param[["caption"]] <- paste("Evaluable", label[2], "to-date")
395		}
396	16x	xTidy <- h_knit_print_select_columns(x)
397		} else {
398	!	xTidy <- h_knit_print_summarise(x, summarise, full_grid)
399	!	if (!("caption" %in% names(param))) {
400	!	param[["caption"]] <- paste0("Summarised by ", summarise)
401		}
402		}
403	16x	param[["x"]] <- xTidy
404	16x	rv <- if (length(x@x) > 0) {
405	!	paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n")
406		} else {
407	16x	paste("No", label[2], "are yet evaluable.\n\n")
408		}
409	16x	rv <- paste0(
410	16x	rv,
411	16x	paste0(
412	16x	"\n\nThe dose grid is ",
413	16x	h_get_formatted_dosegrid(
414	16x	grid = x@doseGrid,
415	16x	units = units,
416		...
417		),
418		""
419		),
420	16x	"\n\n",
421	16x	collpase = "\n"
422		)
423	16x	if (asis) {
424	!	rv <- knitr::asis_output(rv)
425		}
426	16x	rv
427		}
428
429		#' Used to obtain expected format.
430		#' @keywords internal
431		h_knit_format_func <- function(x) {
432	1x	kableExtra::kable_styling(
433	1x	x,
434	1x	bootstrap_options = c("striped", "hover", "condensed")
435		)
436		}
437
438		#' @export
439		#' @method knit_print DataParts
440		#' @rdname knit_print
441		knit_print.DataParts <- function(
442		x,
443		...,
444		asis = TRUE,
445		label = c("participant", "participants"),
446		full_grid = FALSE,
447		summarise = c("none", "dose", "cohort"),
448		summarize = summarise,
449		units = NA,
450		format_func = h_knit_format_func
451		) {
452	!	rv <- NextMethod()
453	!	rv <- paste0(
454	!	rv,
455	!	paste0(
456	!	"\n\nThe part 1 ladder is ",
457	!	h_get_formatted_dosegrid(x@part1Ladder, units)
458		),
459	!	paste0("\n\nThe next part is Part ", x@nextPart, ".\n\n")
460		)
461	!	if (asis) {
462	!	rv <- knitr::asis_output(rv)
463		}
464	!	rv
465		}

1		#' @include helpers_knitr_CohortSize.R
2
3		# Increments ----
4
5		#' Render a `IncrementsRelative` Object
6		#'
7		#' @description `r lifecycle::badge("experimental")`
8		#' @inherit knit_print.CohortSizeConst return
9		#' @param ... passed to [knitr::kable()]
10		#' @inheritParams knit_print.CohortSizeConst
11		#' @section Usage Notes:
12		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
13		#' of `caption` is `"Defined by highest dose administered so far"`. These
14		#' values can be overridden by passing `col.names` and `caption` in the function
15		#' call.
16		#' @export
17		#' @method knit_print IncrementsRelative
18		#' @rdname knit_print
19		knit_print.IncrementsRelative <- function(x, ..., asis = TRUE) {
20	12x	assert_flag(asis)
21
22	12x	param <- list(...)
23	12x	if (!("col.names" %in% names(param))) {
24	12x	param[["col.names"]] <- c("Min", "Max", "Increment")
25		}
26	12x	if (!("caption" %in% names(param))) {
27	12x	param[["caption"]] <- "Defined by highest dose administered so far"
28		}
29	12x	x <- tidy(x)
30	12x	param[["x"]] <- x
31	12x	rv <- kableExtra::add_header_above(
32	12x	do.call(knitr::kable, param),
33	12x	c("Dose" = 2, " " = 1)
34		)
35	12x	rv <- paste0(rv, "\n\n")
36
37	12x	if (asis) {
38	!	rv <- knitr::asis_output(rv)
39		}
40	12x	rv
41		}
42
43		#' Render an `IncrementsRelativeDLT` object
44		#'
45		#' @description `r lifecycle::badge("experimental")`
46		#' @inherit knit_print.CohortSizeConst return
47		#' @param ... passed to [knitr::kable()]
48		#' @inheritParams knit_print.CohortSizeConst
49		#' @section Usage Notes:
50		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
51		#' of `caption` is `"Defined by number of DLTs reported so far"`. These values
52		#' can be overridden by passing `col.names` and `caption` in the function call.
53		#' @export
54		#' @method knit_print IncrementsRelativeDLT
55		#' @rdname knit_print
56		knit_print.IncrementsRelativeDLT <- function(x, ..., asis = TRUE) {
57	!	assert_flag(asis)
58
59	!	param <- list(...)
60	!	if (!("col.names" %in% names(param))) {
61	!	param[["col.names"]] <- c("Min", "Max", "Increment")
62		}
63	!	if (!("caption" %in% names(param))) {
64	!	param[["caption"]] <- "Defined by number of DLTs reported so far"
65		}
66
67	!	param[["x"]] <- tidy(x)
68	!	rv <- kableExtra::add_header_above(
69	!	do.call(knitr::kable, param),
70	!	c("No DLTs" = 2, " " = 1)
71		)
72	!	rv <- paste0(rv, "\n\n")
73
74	!	if (asis) {
75	!	rv <- knitr::asis_output(rv)
76		}
77	!	rv
78		}
79
80		#' Render an `IncrementsDoseLevels` object
81		#'
82		#' @description `r lifecycle::badge("experimental")`
83		#' @inherit knit_print.CohortSizeConst return
84		#' @inheritParams knit_print.CohortSizeConst
85		#' @export
86		#' @rdname knit_print
87		#' @method knit_print IncrementsDoseLevels
88		knit_print.IncrementsDoseLevels <- function(x, ..., asis = TRUE) {
89	!	assert_flag(asis)
90
91	!	rv <- paste0(
92	!	"The maximum increment between cohorts is ",
93	!	x@levels,
94	!	ifelse(x@levels == 1, " level", " levels"),
95	!	" relative to the ",
96	!	ifelse(
97	!	x@basis_level == "last",
98	!	"dose used in the previous cohort.",
99	!	"highest dose used so far."
100		),
101	!	"\n\n"
102		)
103
104	!	if (asis) {
105	!	rv <- knitr::asis_output(rv)
106		}
107	!	rv
108		}
109
110		#' Render an `IncrementsHSRBeta` object
111		#'
112		#' @description `r lifecycle::badge("experimental")`
113		#' @inherit knit_print.CohortSizeConst return
114		#' @inheritParams knit_print.CohortSizeConst
115		#' @export
116		#' @method knit_print IncrementsHSRBeta
117		#' @rdname knit_print
118		knit_print.IncrementsHSRBeta <- function(x, ..., asis = TRUE) {
119	!	assert_flag(asis)
120
121	!	rv <- paste0(
122	!	"The maximum increment is defined by a hard safety rule, independent of the CRM model, ",
123	!	" and based on a beta(",
124	!	x@a,
125		", ",
126	!	x@b,
127		") ",
128	!	"prior with a target toxicity rate of ",
129	!	x@target,
130	!	" and a probability threshold of ",
131	!	x@prob,
132	!	".\n\n"
133		)
134
135	!	if (asis) {
136	!	rv <- knitr::asis_output(rv)
137		}
138	!	rv
139		}
140
141		#' Render an `IncrementsMin` object
142		#'
143		#' @description `r lifecycle::badge("experimental")`
144		#' @inherit knit_print.CohortSizeConst return
145		#' @param ... passed through to the `knit_print` methods of the constituent
146		#' rules
147		#' @inheritParams knit_print.CohortSizeConst
148		#' @export
149		#' @method knit_print IncrementsMin
150		#' @rdname knit_print
151		knit_print.IncrementsMin <- function(x, ..., asis = TRUE) {
152	!	assert_flag(asis)
153
154	!	rv <- paste0(
155	!	"The minimum of the increments defined in the following rules:",
156	!	paste0(
157	!	lapply(
158	!	x@increments_list,
159	!	function(x, ...) {
160	!	knit_print(x, asis = asis, ...)
161		}
162		),
163	!	collapse = "\n"
164		),
165	!	"\n\n",
166	!	paste = "\n"
167		)
168
169	!	if (asis) {
170	!	rv <- knitr::asis_output(rv)
171		}
172	!	rv
173		}
174
175		#' Render an `IncrementsOrdinal` object
176		#' @inherit knit_print.CohortSizeConst return
177		#' @param ... passed through to the `knit_print` method of the standard rule
178		#' @inheritParams knit_print.CohortSizeConst
179		#' @export
180		#' @method knit_print IncrementsOrdinal
181		#' @rdname knit_print
182		knit_print.IncrementsOrdinal <- function(x, ..., asis = TRUE) {
183	!	assert_flag(asis)
184
185	!	rv <- paste0(
186	!	"Based on a toxicity grade of ",
187	!	x@grade,
188		": ",
189	!	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
190	!	"\n\n",
191	!	paste = "\n"
192		)
193
194	!	if (asis) {
195	!	rv <- knitr::asis_output(rv)
196		}
197	!	rv
198		}
199
200		#' Render an `IncrementsRelativeParts` object
201		#'
202		#' @inherit knit_print.CohortSizeConst return
203		#' @param tox_label (`character`)\cr The word used to describe toxicities. See
204		#' Usage Notes below.
205		#' @inheritParams knit_print.CohortSizeConst
206		#' @section Usage Notes:
207		#' `label` defines how toxicities are described.
208		#'
209		#' It should be a character vector of length 1 or 2. If of length 2, the first
210		#' element describes a single toxicity and the second describes all other
211		#' toxicity counts. If of length 1, the character `s` is appended to the value
212		#' describing a single toxicity.
213		#'
214		#' @export
215		#' @method knit_print IncrementsRelativeParts
216		#' @rdname knit_print
217		knit_print.IncrementsRelativeParts <- function(
218		x,
219		...,
220		asis = TRUE,
221		tox_label = c("toxicity", "toxicities")
222		) {
223	!	assert_flag(asis)
224
225	!	tox_label <- h_prepare_labels(tox_label)
226	!	rv <- paste0(
227	!	"The maximum increment in Part 1 is defined by the `part1Ladder` slot of ",
228	!	"the associated `DataParts` object.\n\n",
229	!	"If no ",
230	!	tox_label[2],
231	!	" are reported in Part 1, the starting dose for Part 2 ",
232	!	"will be ",
233	!	ifelse(
234	!	x@clean_start == 0,
235	!	"the highest dose used in Part 1.\n\n",
236	!	paste0(
237	!	x@clean_start,
238	!	ifelse(abs(x@clean_start) == 1, " dose ", " doses "),
239	!	ifelse(x@clean_start < 0, "below ", "above "),
240	!	"the highest dose used in Part 1.\n\n"
241		)
242		),
243	!	"If one or more ",
244	!	tox_label[2],
245	!	" are reported in Part 1, the starting dose for Part 2 ",
246	!	"will be ",
247	!	ifelse(
248	!	x@dlt_start == 0,
249	!	"the highest dose used in Part 1.\n\n",
250	!	paste0(
251	!	abs(x@dlt_start),
252	!	ifelse(abs(x@dlt_start) == 1, " dose ", " doses "),
253	!	ifelse(x@dlt_start < 0, "below ", "above "),
254	!	"the highest dose used in Part 1.\n\n"
255		)
256		),
257	!	"Once Part 2 has started, the maximum increment in dose levels will be based ",
258	!	"on the number of ",
259	!	tox_label[2],
260	!	" reported so far, as described in the ",
261	!	"following table:"
262		)
263
264	!	param <- list(...)
265	!	if (!("col.names" %in% names(param))) {
266	!	param[["col.names"]] <- c("Lower", "Upper", "Increment")
267		}
268	!	if (!("caption" %in% names(param))) {
269	!	param[["caption"]] <- paste0(
270	!	"Defined by the number of ",
271	!	tox_label[2],
272	!	" reported so far"
273		)
274		}
275	!	header <- c(2, 1)
276	!	headerLabel <- tox_label[2]
277	!	substr(headerLabel, 1, 1) <- toupper(substr(headerLabel, 1, 1))
278	!	names(header) <- c(headerLabel, " ")
279	!	param[["x"]] <- tibble(
280	!	intervals = x@intervals
281		) %>%
282	!	h_range_to_minmax(intervals) %>%
283	!	tibble::add_column(increments = c(0, x@increments))
284	!	d_tab <- kableExtra::add_header_above(
285	!	do.call(knitr::kable, param),
286	!	header
287		)
288	!	rv <- paste(rv, d_tab, "\n\n")
289	!	if (asis) {
290	!	rv <- knitr::asis_output(rv)
291		}
292	!	rv
293		}
294
295		#' Render an `IncrementsRelativeDLTCurrent` object
296		#'
297		#' @description `r lifecycle::badge("experimental")`
298		#' @inherit knit_print.CohortSizeConst return
299		#' @param tox_label (`character`)\cr The word used to describe toxicities. See
300		#' Usage Notes below.
301		#' @param ... passed to [knitr::kable()]
302		#' @inheritParams knit_print.CohortSizeConst
303		#' @section Usage Notes:
304		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
305		#' of `caption` is `"Defined by number of DLTs in the current cohort"`. These values
306		#' can be overridden by passing `col.names` and `caption` in the function call.
307		#'
308		#' `tox_label` defines how toxicities are described.
309		#'
310		#' It should be a character vector of length 1 or 2. If of length 2, the first
311		#' element describes a single toxicity and the second describes all other
312		#' toxicity counts. If of length 1, the character `s` is appended to the value
313		#' describing a single toxicity.
314		#'
315		#' @export
316		#' @method knit_print IncrementsRelativeDLTCurrent
317		#' @rdname knit_print
318		knit_print.IncrementsRelativeDLTCurrent <- function(
319		x,
320		...,
321		asis = TRUE,
322		tox_label = c("DLT", "DLTs")
323		) {
324	!	assert_flag(asis)
325	!	assert_character(tox_label, min.len = 1, max.len = 2, any.missing = FALSE)
326
327	!	if (length(tox_label) == 1) {
328	!	tox_label[2] <- paste0(tox_label[1], "s")
329		}
330
331	!	param <- list(...)
332	!	if (!("col.names" %in% names(param))) {
333	!	param[["col.names"]] <- c("Min", "Max", "Increment")
334		}
335	!	if (!("caption" %in% names(param))) {
336	!	param[["caption"]] <- paste0(
337	!	"Defined by number of ",
338	!	tox_label[2],
339	!	" reported in the current cohort"
340		)
341		}
342	!	param[["x"]] <- tidy(x)
343	!	header_text <- c(2, 1)
344	!	names(header_text) <- c(paste0("No ", tox_label[2]), " ")
345	!	rv <- kableExtra::add_header_above(
346	!	do.call(knitr::kable, param),
347	!	header_text
348		)
349	!	rv <- paste0(rv, "\n\n")
350
351	!	if (asis) {
352	!	rv <- knitr::asis_output(rv)
353		}
354	!	rv
355		}

1		#' @include helpers.R
2		#' @include Data-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# GeneralData-class ----
7
8		#' `GeneralData`
9		#'
10		#' @description `r lifecycle::badge("stable")`
11		#'
12		#' [`GeneralData`] is a class for general data input.
13		#'
14		#' @slot ID (`integer`)\cr unique patient IDs.
15		#' @slot cohort (`integer`)\cr the cohort (non-negative sorted) indices.
16		#' @slot nObs (`integer`)\cr number of observations, a single value.
17		#'
18		#' @aliases GeneralData
19		#' @export
20		#'
21		.GeneralData <- setClass(
22		Class = "GeneralData",
23		slots = c(
24		ID = "integer",
25		cohort = "integer",
26		nObs = "integer"
27		),
28		prototype = prototype(
29		ID = integer(),
30		cohort = integer(),
31		nObs = 0L
32		),
33		contains = "CrmPackClass",
34		validity = v_general_data
35		)
36
37		## default constructor ----
38
39		#' @rdname GeneralData-class
40		#' @note Typically, end users will not use the `.DefaultDataGeneral()` function.
41		#' @export
42		.DefaultDataGeneral <- function() {
43	!	stop(paste0(
44	!	"Class DataGeneral cannot be instantiated directly. Please use one of its subclasses instead."
45		))
46		}
47
48		# Data ----
49
50		## class ----
51
52		#' `Data`
53		#'
54		#' @description `r lifecycle::badge("stable")`
55		#'
56		#' [`Data`] is a class for the data input.
57		#' It inherits from [`GeneralData`].
58		#'
59		#' @slot x (`numeric`)\cr the doses for the patients.
60		#' @slot y (`integer`)\cr the vector of toxicity events (0 or 1 integers).
61		#' @slot doseGrid (`numeric`)\cr the vector of all possible doses (sorted),
62		#' i.e. the dose grid.
63		#' @slot nGrid (`integer`)\cr number of gridpoints.
64		#' @slot xLevel (`integer`)\cr the levels for the doses the patients have been given,
65		#' w.r.t `doseGrid`.
66		#' @slot placebo (`logical`)\cr if `TRUE` the first dose level
67		#' in the `doseGrid`is considered as PLACEBO.
68		#'
69		#' @aliases Data
70		#' @export
71		#'
72		.Data <- setClass(
73		Class = "Data",
74		contains = "GeneralData",
75		slots = c(
76		x = "numeric",
77		y = "integer",
78		doseGrid = "numeric",
79		nGrid = "integer",
80		xLevel = "integer",
81		placebo = "logical"
82		),
83		prototype = prototype(
84		x = numeric(),
85		y = integer(),
86		doseGrid = numeric(),
87		nGrid = 0L,
88		xLevel = integer(),
89		placebo = FALSE
90		),
91		validity = v_data
92		)
93
94		## constructor ----
95
96		#' @rdname Data-class
97		#'
98		#' @details The `cohort` can be missing if and only if `placebo` is equal to
99		#' `FALSE`.
100		#'
101		#' @note `ID` and `cohort` can be missing. Then a message will be issued
102		#' and the variables will be filled with default IDs and best guesses cohort,
103		#' i.e. a sorted (in ascending order) sequence of values from `{1, 2, ...}`.
104		#'
105		#' @param x (`numeric`)\cr the doses for the patients.
106		#' @param y (`integer`)\cr the vector of toxicity events (0 or 1).
107		#' You can also supply `numeric` vectors, but these will then be converted to
108		#' `integer` internally.
109		#' @param ID (`integer`)\cr unique patient IDs.
110		#' You can also supply `numeric` vectors, but these will then be converted to
111		#' `integer` internally.
112		#' @param cohort (`integer`)\cr the cohort (non-negative sorted) indices.
113		#' You can also supply `numeric` vectors, but these will then be converted to
114		#' `integer` internally.
115		#' @param doseGrid (`numeric`)\cr all possible doses.
116		#' @param placebo (`flag`)\cr if `TRUE` the first dose level
117		#' in the `doseGrid` is considered as placebo.
118		#' @param ... not used.
119		#'
120		#' @export
121		#' @example examples/Data-class.R
122		#'
123		Data <- function(
124		x = numeric(),
125		y = integer(),
126		ID = integer(),
127		cohort = integer(),
128		doseGrid = numeric(),
129		placebo = FALSE,
130		...
131		) {
132	440x	assert_numeric(x)
133	440x	assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
134	440x	assert_integerish(ID, unique = TRUE, any.missing = FALSE)
135	440x	assert_integerish(cohort)
136	440x	if (length(x) > 0) {
137	281x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE, min.len = 1)
138		} else {
139	159x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
140		}
141	439x	assert_flag(placebo)
142
143	439x	doseGrid <- sort(doseGrid)
144	439x	assert_subset(x, doseGrid)
145
146	439x	if (length(ID) == 0 && length(x) > 0) {
147	1x	message("Used default patient IDs!")
148	1x	ID <- seq_along(x)
149		} else {
150	438x	assert_integerish(ID, unique = TRUE)
151		}
152
153	439x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
154	1x	message("Used best guess cohort indices!")
155		# This is just assuming that consecutive patients
156		# in the data set are in the same cohort if they
157		# have the same dose. Note that this could be wrong,
158		# if two subsequent cohorts are at the same dose.
159	1x	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
160		} else {
161	438x	assert_integerish(cohort)
162		}
163
164	439x	.Data(
165	439x	x = as.numeric(x),
166	439x	y = as.integer(y),
167	439x	ID = as.integer(ID),
168	439x	cohort = as.integer(cohort),
169	439x	doseGrid = as.numeric(doseGrid),
170	439x	nObs = length(x),
171	439x	nGrid = length(doseGrid),
172	439x	xLevel = match_within_tolerance(x, doseGrid),
173	439x	placebo = placebo
174		)
175		}
176
177		## default constructor ----
178
179		#' @rdname Data-class
180		#' @note Typically, end users will not use the `.DefaultData()` function.
181		#' @export
182		.DefaultData <- function() {
183	6x	Data(
184	6x	doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
185	6x	ID = 1L:3L,
186	6x	cohort = 1L:3L,
187	6x	x = c(1, 3, 5),
188	6x	y = rep(0L, 3)
189		)
190		}
191
192		# DataDual ----
193
194		## class ----
195
196		#' `DataDual`
197		#'
198		#' @description `r lifecycle::badge("stable")`
199		#'
200		#' [`DataDual`] is a class for the dual endpoint data.
201		#' It inherits from [`Data`] and it contains additional biomarker information.
202		#'
203		#' @slot w (`numeric`)\cr the continuous vector of biomarker values.
204		#'
205		#' @aliases DataDual
206		#' @export
207		#'
208		.DataDual <- setClass(
209		Class = "DataDual",
210		slots = c(w = "numeric"),
211		prototype = prototype(w = numeric()),
212		contains = "Data",
213		validity = v_data_dual
214		)
215
216		## constructor ----
217
218		#' @rdname DataDual-class
219		#'
220		#' @param w (`numeric`)\cr the continuous vector of biomarker values.
221		#' @param ... parameters passed to [Data()].
222		#'
223		#' @export
224		#' @example examples/Data-class-DataDual.R
225		#'
226		DataDual <- function(w = numeric(), ...) {
227	133x	d <- Data(...)
228	133x	.DataDual(d, w = w)
229		}
230
231
232		## default constructor ----
233
234		#' @rdname DataDual-class
235		#' @note Typically, end users will not use the `.DefaultDataDual()` function.
236		#' @export
237		.DefaultDataDual <- function() {
238	3x	set.seed(1230)
239	3x	DataDual(
240	3x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
241	3x	y = c(0, 0, 0, 0, 0, 0, 1, 0),
242	3x	w = rnorm(8),
243	3x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
244	3x	ID = 1L:8L,
245	3x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
246		)
247		}
248
249		# DataParts ----
250
251		## class ----
252
253		#' `DataParts`
254		#'
255		#' @description `r lifecycle::badge("stable")`
256		#'
257		#' [`DataParts`] is a class for the data with two study parts.
258		#' It inherits from [`Data`] and it contains additional information
259		#' on the two study parts.
260		#'
261		#' @slot part (`integer`)\cr which part does each of the patients belong to?
262		#' @slot nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
263		#' @slot part1Ladder (`numeric`)\cr what is the escalation ladder for
264		#' part 1? This shall be an ordered subset of the `doseGrid`.
265		#'
266		#' @aliases DataParts
267		#' @export
268		#'
269		.DataParts <- setClass(
270		Class = "DataParts",
271		slots = c(
272		part = "integer",
273		nextPart = "integer",
274		part1Ladder = "numeric"
275		),
276		prototype = prototype(
277		part = integer(),
278		nextPart = 1L,
279		part1Ladder = numeric()
280		),
281		contains = "Data",
282		validity = v_data_parts
283		)
284
285		## constructor ----
286
287		#' @rdname DataParts-class
288		#'
289		#' @param part (`integer`)\cr which part does each of the patients belong to?
290		#' @param nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
291		#' @param part1Ladder (`numeric`)\cr what is the escalation ladder for part 1?
292		#' This shall be an ordered subset of the `doseGrid`.
293		#' @param ... parameters passed to [Data()].
294		#'
295		#' @export
296		#' @example examples/Data-class-DataParts.R
297		#'
298		DataParts <- function(
299		part = integer(),
300		nextPart = 1L,
301		part1Ladder = numeric(),
302		...
303		) {
304	5x	d <- Data(...)
305	5x	.DataParts(
306	5x	d,
307	5x	part = part,
308	5x	nextPart = nextPart,
309	5x	part1Ladder = part1Ladder
310		)
311		}
312
313		## default constructor ----
314
315		#' @rdname DataParts-class
316		#' @note Typically, end users will not use the `.DefaultDataParts()` function.
317		#' @export
318		.DefaultDataParts <- function() {
319	3x	DataParts(
320	3x	x = c(0.1, 0.5, 1.5),
321	3x	y = c(0, 0, 0),
322	3x	ID = 1:3,
323	3x	cohort = 1:3,
324	3x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
325	3x	part = c(1L, 1L, 1L),
326	3x	nextPart = 1L,
327	3x	part1Ladder = c(0.1, 0.5, 1.5, 3, 6, 10)
328		)
329		}
330
331
332		# DataMixture ----
333
334		## class ----
335
336		#' `DataMixture`
337		#'
338		#' @description `r lifecycle::badge("stable")`
339		#'
340		#' [`DataMixture`] is a class for the data with mixture sharing.
341		#' It inherits from [`Data`] and it contains additional information
342		#' on the mixture sharing.
343		#'
344		#' @slot xshare (`numeric`)\cr the doses for the share patients.
345		#' @slot yshare (`integer`)\cr the vector of toxicity events (0 or 1)
346		#' for the share patients.
347		#' @slot nObsshare (`count`)\cr number of share patients.
348		#'
349		#' @aliases DataMixture
350		#' @export
351		#'
352		.DataMixture <- setClass(
353		Class = "DataMixture",
354		slots = c(
355		xshare = "numeric",
356		yshare = "integer",
357		nObsshare = "integer"
358		),
359		prototype = prototype(
360		xshare = numeric(),
361		yshare = integer(),
362		nObsshare = 0L
363		),
364		contains = "Data",
365		validity = v_data_mixture
366		)
367
368		## constructor ----
369
370		#' @rdname DataMixture-class
371		#'
372		#' @param xshare (`numeric`)\cr the doses for the share patients.
373		#' @param yshare (`integer`)\cr the vector of toxicity events (0 or 1)
374		#' for the share patients. You can also supply `numeric` vectors,
375		#' but these will then be converted to `integer` internally.
376		#' @param ... parameters passed to [Data()].
377		#'
378		#' @export
379		#' @example examples/Data-class-DataMixture.R
380		#'
381		DataMixture <- function(xshare = numeric(), yshare = integer(), ...) {
382	5x	d <- Data(...)
383	5x	assert_integerish(yshare)
384	5x	assert_numeric(xshare)
385	5x	.DataMixture(
386	5x	d,
387	5x	xshare = as.numeric(xshare),
388	5x	yshare = as.integer(yshare),
389	5x	nObsshare = length(xshare)
390		)
391		}
392
393		## default constructor ----
394
395		#' @rdname DataMixture-class
396		#' @note Typically, end users will not use the `.DefaultDataMixture()` function.
397		#' @export
398		.DefaultDataMixture <- function() {
399	3x	DataMixture(
400	3x	xshare = c(12, 14, 16, 18.0),
401	3x	yshare = c(0L, 1L, 1L, 1L),
402	3x	nObsshare = 4L,
403	3x	x = c(0.1, 0.5, 1.5),
404	3x	y = c(0, 0, 0),
405	3x	ID = 1L:3L,
406	3x	cohort = 1L:3L,
407	3x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2))
408		)
409		}
410
411
412		# DataDA ----
413
414		## class ----
415
416		#' `DataDA`
417		#'
418		#' @description `r lifecycle::badge("stable")`
419		#'
420		#' [`DataDA`] is a class for the time-to-DLT augmented data.
421		#' It inherits from [`Data`] and it contains additional DLT free survival times.
422		#'
423		#' @note `survival time` here refers to the time period for which the subject
424		#' did not experience any DLT, and is not referring to deaths.
425		#'
426		#' @slot u (`numeric`)\cr the continuous vector of DLT free survival times.
427		#' @slot t0 (`numeric`)\cr time of initial dosing for each patient.
428		#' Non-negative values sorted in ascending order.
429		#' @slot Tmax (`number`)\cr the DLT observation period.
430		#'
431		#' @aliases DataDA
432		#' @export
433		#'
434		.DataDA <- setClass(
435		Class = "DataDA",
436		slots = c(
437		u = "numeric",
438		t0 = "numeric",
439		Tmax = "numeric"
440		),
441		prototype = prototype(
442		u = numeric(),
443		t0 = numeric(),
444		Tmax = 0 + .Machine$double.xmin
445		),
446		contains = "Data",
447		validity = v_data_da
448		)
449
450		## constructor ----
451
452		#' @rdname DataDA-class
453		#'
454		#' @param u (`numeric`)\cr the continuous vector of DLT free survival times.
455		#' @param t0 (`numeric`)\cr time of initial dosing for each patient.
456		#' Non-negative values sorted in ascending order.
457		#' Default to vector of 0s of length equal to length of `u`.
458		#' @param Tmax (`number`)\cr the DLT observation period.
459		#' @param ... parameters passed to [Data()].
460		#'
461		#' @export
462		#' @example examples/Data-class-DataDA.R
463		#'
464		DataDA <- function(
465		u = numeric(),
466		t0 = numeric(length(u)),
467		Tmax = 0 + .Machine$double.xmin,
468		...
469		) {
470	15x	d <- Data(...)
471	15x	.DataDA(
472	15x	d,
473	15x	u = as.numeric(u),
474	15x	t0 = as.numeric(t0),
475	15x	Tmax = as.numeric(Tmax)
476		)
477		}
478
479		## default constructor ----
480
481		#' @rdname DataDA-class
482		#' @note Typically, end users will not use the `.DefaultDataDA()` function.
483		#' @export
484		.DefaultDataDA <- function() {
485	3x	DataDA(
486	3x	u = c(42, 30, 15, 5, 20, 25, 30, 60),
487	3x	t0 = c(0, 15, 30, 40, 55, 70, 75, 85),
488	3x	Tmax = 60,
489	3x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
490	3x	y = c(0, 0, 1, 1, 0, 0, 1, 0),
491	3x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
492	3x	ID = 1L:8L,
493	3x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
494		)
495		}
496
497		# DataOrdinal ----
498
499		## class ----
500
501		#' `DataOrdinal`
502		#'
503		#' @description `r lifecycle::badge("experimental")`
504		#'
505		#' [`DataOrdinal`] is a class for ordinal toxicity data.
506		#' It inherits from [`GeneralData`] and it describes toxicity responses on an
507		#' ordinal rather than binary scale.
508		#'
509		#' @note This class has been implemented as a sibling of the existing `Data` class
510		#' (rather than as a parent or child) to minimise the risk of unintended side
511		#' effects on existing classes and methods.
512		#'
513		#' The default setting for the `yCategories` slot replicates the behaviour
514		#' of the existing `Data` class.
515		#'
516		#' @aliases DataOrdinal
517		#' @export
518		.DataOrdinal <- setClass(
519		Class = "DataOrdinal",
520		contains = "GeneralData",
521		slots = c(
522		x = "numeric",
523		y = "integer",
524		doseGrid = "numeric",
525		nGrid = "integer",
526		xLevel = "integer",
527		yCategories = "integer",
528		placebo = "logical"
529		),
530		prototype = prototype(
531		x = numeric(),
532		y = integer(),
533		doseGrid = numeric(),
534		nGrid = 0L,
535		xLevel = integer(),
536		yCategories = c("No DLT" = 0L, "DLT" = 1L),
537		placebo = FALSE
538		),
539		validity = v_data_ordinal
540		)
541
542		## constructor ----
543
544		#' @rdname DataOrdinal-class
545		#' @param yCategories (named `integer`)\cr the names and codes for the
546		#' toxicity categories used in the data. Category labels are taken from the
547		#' names of the vector. The names of the vector must be unique and its values
548		#' must be sorted and take the values 0, 1, 2, ...
549		#' @inheritParams Data
550		#' @inherit Data details note params
551		#' @example examples/Data-class-DataOrdinal.R
552		#' @export
553		DataOrdinal <- function(
554		x = numeric(),
555		y = integer(),
556		ID = integer(),
557		cohort = integer(),
558		doseGrid = numeric(),
559		placebo = FALSE,
560		yCategories = c("No DLT" = 0L, "DLT" = 1L),
561		...
562		) {
563	52x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
564	52x	assert_integerish(
565	52x	yCategories,
566	52x	any.missing = FALSE,
567	52x	unique = TRUE,
568	52x	names = "unique",
569	52x	min.len = 2
570		)
571	52x	assert_flag(placebo)
572
573	52x	doseGrid <- as.numeric(sort(doseGrid))
574
575	52x	if (length(ID) == 0 && length(x) > 0) {
576	!	message("Used default patient IDs!")
577	!	ID <- seq_along(x)
578		} else {
579	52x	assert_integerish(ID, unique = TRUE)
580		}
581
582	52x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
583	!	message("Used best guess cohort indices!")
584		# This is just assuming that consecutive patients
585		# in the data set are in the same cohort if they
586		# have the same dose. Note that this could be wrong,
587		# if two subsequent cohorts are at the same dose.
588	!	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
589		} else {
590	52x	assert_integerish(cohort)
591		}
592
593	52x	.DataOrdinal(
594	52x	x = as.numeric(x),
595	52x	y = as.integer(y),
596	52x	ID = as.integer(ID),
597	52x	cohort = as.integer(cohort),
598	52x	doseGrid = doseGrid,
599	52x	nObs = length(x),
600	52x	nGrid = length(doseGrid),
601	52x	xLevel = match_within_tolerance(x = x, table = doseGrid),
602	52x	placebo = placebo,
603	52x	yCategories = yCategories
604		)
605		}
606
607
608		## default constructor ----
609
610		#' @rdname DataOrdinal-class
611		#' @note Typically, end users will not use the `.DefaultDataOrdinal()` function.
612		#' @export
613		.DefaultDataOrdinal <- function() {
614	16x	DataOrdinal(
615	16x	x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
616	16x	y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
617	16x	ID = 1L:10L,
618	16x	cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
619	16x	doseGrid = c(seq(from = 10, to = 100, by = 10)),
620	16x	yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
621	16x	placebo = FALSE
622		)
623		}
624
625		# DataGrouped ----
626
627		## class ----
628
629		#' `DataGrouped`
630		#'
631		#' @description `r lifecycle::badge("stable")`
632		#'
633		#' [`DataGrouped`] is a class for a two groups dose escalation data set,
634		#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
635		#' arm. It inherits from [`Data`] and it contains the additional group information.
636		#'
637		#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
638		#'
639		#' @aliases DataGrouped
640		#' @export
641		.DataGrouped <- setClass(
642		Class = "DataGrouped",
643		slots = c(
644		group = "factor"
645		),
646		prototype = prototype(
647		group = factor(levels = c("mono", "combo"))
648		),
649		contains = "Data",
650		validity = v_data_grouped
651		)
652
653		#' @rdname DataGrouped-class
654		#'
655		#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
656		#' If `character` then will be coerced to `factor` with the correct levels
657		#' internally.
658		#' @param ... parameters passed to [Data()].
659		#'
660		#' @export
661		#' @example examples/Data-class-DataGrouped.R
662		#'
663		DataGrouped <- function(group = character(), ...) {
664	7x	d <- Data(...)
665	7x	if (!is.factor(group)) {
666	7x	assert_character(group)
667	7x	assert_subset(group, choices = c("mono", "combo"))
668	7x	group <- factor(group, levels = c("mono", "combo"))
669		}
670	7x	.DataGrouped(
671	7x	d,
672	7x	group = group
673		)
674		}
675
676		## default constructor ----
677
678		#' @rdname DataGrouped-class
679		#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
680		#' @export
681		.DefaultDataGrouped <- function() {
682	4x	DataGrouped(
683	4x	group = c("mono", "mono", "combo"),
684	4x	x = c(1, 3, 5),
685	4x	y = c(0, 0, 0),
686	4x	ID = 1L:3L,
687	4x	cohort = 1L:3L,
688	4x	doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
689	4x	placebo = FALSE
690		)
691		}

1		#' @include helpers.R
2		NULL
3
4		#' Appending a Dummy Number for Selected Slots in Data
5		#'
6		#' @description `r lifecycle::badge("experimental")`
7		#'
8		#' A helper function that appends a dummy value to a given slots in [`GeneralData`]
9		#' class object, if and only if the total number of observations (as indicated
10		#' by `object@nObs`) equals to `1`. Otherwise, the `object` is not changed.
11		#'
12		#' @note The main motivation behind this function is related to the `JAGS`.
13		#' If there is only one observation, the data is not passed correctly to
14		#' `JAGS`, i.e. e.g. `x` and `y` are treated like scalars in the data file.
15		#' Therefore it is necessary to add dummy values to the vectors in this case
16		#' As we don't change the number of observations (`nObs`), this addition of
17		#' zeros doesn't affect the results of `JAGS` computations.
18		#'
19		#' @param object (`GeneralData`)\cr object into which dummy values will be added.
20		#' @param where (`character`)\cr names of slots in `object` to which a `dummy`
21		#' number will be appended.
22		#' @param dummy (`number`)\cr a dummy number that will be appended to selected
23		#' slots in `object`. Default to `0`.
24		#'
25		#' @return A [`GeneralData`] object with slots updated with dummy number.
26		#'
27		#' @export
28		#' @example examples/helpers-jags_add_dummy.R
29		#'
30		h_jags_add_dummy <- function(object, where, dummy = 0) {
31	107x	assert_class(object, "GeneralData")
32	107x	assert_character(where)
33	107x	assert_subset(where, slotNames(object))
34	106x	assert_number(dummy)
35
36	106x	if (object@nObs == 1L) {
37	2x	for (i in where) {
38		# Add dummy value and preserve the class.
39	3x	slot(object, i) <- as(c(slot(object, i), dummy), class(slot(object, i)))
40		}
41		}
42	106x	object
43		}
44
45		#' Joining `JAGS` Models
46		#'
47		#' @description `r lifecycle::badge("stable")`
48		#'
49		#' This helper function joins two JAGS models in the way that the body of the
50		#' second model is appended to the body of the first model (in this order).
51		#' After that, the first, body-extended model is returned. The arguments of
52		#' `model1`, `model2` model functions (if any) are not combined in any way.
53		#'
54		#' @note `model1` and `model2` functions must have a multi-expression
55		#' body, i.e. braced expression(s). Environments or any attributes of the
56		#' function bodies are not preserved in any way after joining.
57		#'
58		#' @param model1 (`function`)\cr the first model to join.
59		#' @param model2 (`function`)\cr the second model to join.
60		#'
61		#' @return joined models.
62		#'
63		#' @export
64		#'
65		h_jags_join_models <- function(model1, model2) {
66	406x	assert_function(model1)
67	406x	assert_function(model2)
68	406x	assert_class(body(model1), "{")
69	405x	assert_class(body(model2), "{")
70
71		# This workaround is needed to avoid bugs related to covr-injected code.
72	405x	if (h_covr_active()) {
73	405x	body(model2) <- h_covr_detrace(body(model2))
74		}
75
76	405x	body2 <- as.list(body(model2))
77	405x	if (length(body2) >= 2) {
78	404x	body1 <- as.list(body(model1))
79	404x	body(model1) <- as.call(c(body1, body2[-1]))
80		}
81	405x	model1
82		}
83
84
85		#' Setting Initial Values for `JAGS` Model Parameters
86		#'
87		#' @description `r lifecycle::badge("experimental")`
88		#'
89		#' A simple helper function that prepares an object for `inits` argument of
90		#' [rjags::jags.model()], which is invoked by [mcmc()] method. The `inits`
91		#' argument specifies initial values for model parameters.
92		#'
93		#' @param model (`GeneralModel`)\cr an input model.
94		#' @param data (`GeneralData`)\cr an input data.
95		#'
96		#' @return A `list` of starting values for parameters required to be initialized
97		#' in the MCMC `JAGS `sampler.
98		#'
99		#' @export
100		#' @example examples/helpers-jags_get_model_inits.R
101		#'
102		h_jags_get_model_inits <- function(model, data) {
103	100x	assert_class(model, "GeneralModel")
104	100x	assert_class(data, "GeneralData")
105
106	100x	inits <- do.call(model@init, h_slots(data, formalArgs(model@init)))
107	100x	assert_list(inits)
108	99x	inits[sapply(inits, length) > 0L]
109		}
110
111		#' Getting Data for `JAGS`
112		#'
113		#' @description `r lifecycle::badge("experimental")`
114		#'
115		#' A simple helper function that prepares an object for `data` argument of
116		#' [rjags::jags.model()], which is invoked by [mcmc()] method.
117		#'
118		#' @param model (`GeneralModel`)\cr an input model.
119		#' @param data (`GeneralData`)\cr an input data.
120		#' @param from_prior (`flag`)\cr sample from the prior only? In this case
121		#' data will not be appended to the output, i.e. only the variables required
122		#' by the `model@priormodel` model will be returned in data.
123		#'
124		#' @export
125		#' @example examples/helpers-jags_get_data.R
126		#'
127		h_jags_get_data <- function(model, data, from_prior) {
128	103x	assert_class(model, "GeneralModel")
129	103x	assert_class(data, "GeneralData")
130	103x	assert_flag(from_prior)
131
132		# 1) Extract variables from `data` as required by `modelspecs`.
133	103x	ms_args_names <- formalArgs(model@modelspecs)
134	103x	ms_args <- if ("from_prior" %in% ms_args_names) {
135	97x	c(
136	97x	h_slots(data, setdiff(ms_args_names, "from_prior")),
137	97x	list(from_prior = from_prior)
138		)
139		} else {
140	6x	h_slots(data, ms_args_names)
141		}
142	103x	modelspecs <- do.call(model@modelspecs, ms_args)
143	103x	assert_list(modelspecs)
144
145		# 2) Extract variables from `data` as required by `datanames`.
146	102x	datanames <- if (from_prior) {
147	38x	model@datanames_prior
148		} else {
149	64x	union(model@datanames, model@datanames_prior)
150		}
151
152		# Add dummy to ensure that e.g. `x` and `y` in `data` won't be treated as
153		# scalars by `JAGS` if `data@nObs == 1`, which leads to failures.
154	102x	add_where <- setdiff(
155	102x	datanames,
156	102x	c("nObs", "nGrid", "nObsshare", "yshare", "xshare", "Tmax")
157		)
158	102x	data <- h_jags_add_dummy(data, where = add_where)
159
160	102x	data_model <- h_slots(data, datanames)
161	102x	c(data_model, modelspecs)
162		}
163
164		#' Writing JAGS Model to a File
165		#'
166		#' @description `r lifecycle::badge("stable")`
167		#'
168		#' This function converts a R function with JAGS model into a text and then
169		#' writes it into a given file. During the "model into text" conversion, the
170		#' format of numbers of which absolute value is less than `0.001` or greater
171		#' than `10000` is changed. These numbers will be converted into scientific
172		#' format with specified number of significant digits using [formatC()]
173		#' function.
174		#'
175		#' @note JAGS syntax allows truncation specification like `dnorm(...) I(...)`,
176		#' which is illegal in R. To overcome this incompatibility, use dummy operator
177		#' `\%_\%` before `I(...)`, i.e. `dnorm(...) \%_\% I(...)` in the model's
178		#' code. This dummy operator `\%_\%` will be removed just before saving the
179		#' JAGS code into a file.
180		#' Due to technical issues related to conversion of numbers to scientific
181		#' format, it is required that the body of a model function does not contain
182		#' `TEMP_NUM_PREF_` or `_TEMP_NUM_SUF` character constants in its body.
183		#'
184		#' @param model (`function`)\cr function containing the JAGS model.
185		#' @param file (`string` or `NULL`)\cr the name of the file (including the
186		#' optional path) where the model will be saved. If `NULL`, the file will be
187		#' created in a `R_crmPack` folder placed under temporary directory indicated
188		#' by [tempdir()] function.
189		#' @param digits (`count`)\cr a desired number of significant digits for
190		#' for numbers used in JAGS input, see [formatC()].
191		#' @return The name of the file where the model was saved.
192		#'
193		#' @export
194		#' @example examples/helpers-jags_write_model.R
195		#'
196		h_jags_write_model <- function(model, file = NULL, digits = 5) {
197	99x	assert_function(model)
198	99x	assert_count(digits)
199
200		# This workaround is needed to avoid bugs related to covr-injected code.
201	99x	if (h_covr_active()) {
202	99x	body(model) <- h_covr_detrace(body(model))
203		}
204
205	99x	if (!is.null(file)) {
206	1x	assert_path_for_output(file)
207		} else {
208	98x	dir <- file.path(tempdir(), "R_crmPack")
209		# Don't warn, as the temp dir often exists (which is OK).
210	98x	dir.create(dir, showWarnings = FALSE)
211	98x	file <- tempfile(
212	98x	pattern = "jags_model_fun",
213	98x	tmpdir = dir,
214	98x	fileext = ".txt"
215		)
216		}
217
218		# Replace scientific notation.
219	99x	model_sci_replaced <- h_rapply(
220	99x	x = body(model),
221	99x	fun = h_format_number,
222	99x	classes = c("integer", "numeric"),
223	99x	digits = digits,
224	99x	prefix = "TEMP_NUM_PREF_",
225	99x	suffix = "_TEMP_NUM_SUF"
226		)
227		# Transform `model` body into character vector.
228	99x	model_text <- deparse(model_sci_replaced, control = NULL)
229	99x	model_text <- gsub("\"TEMP_NUM_PREF_\|_TEMP_NUM_SUF\"", "", model_text)
230	99x	model_text <- gsub("%_% ", "", model_text)
231	99x	model_text <- c("model", model_text)
232
233	99x	log_trace("Writting JAGS model function into: %s", file)
234	99x	writeLines(model_text, con = file)
235	99x	file
236		}
237
238		#' Extracting Samples from `JAGS` `mcarray` Object
239		#'
240		#' @description `r lifecycle::badge("stable")`
241		#'
242		#' A simple helper function that extracts a sample from
243		#' [`rjags::mcarray.object`] S3 class object. The [`rjags::mcarray.object`]
244		#' object is used by the [rjags::jags.samples()] function to represent MCMC
245		#' output from a `JAGS` model.
246		#'
247		#' @param x an [`rjags::mcarray.object`] object.
248		#'
249		#' @export
250		#'
251		h_jags_extract_samples <- function(x) {
252	292x	assert_class(x, "mcarray")
253
254	292x	x <- x[,, 1L]
255		# In case that there are multiple parameters in a node.
256	292x	if (is.matrix(x)) {
257	99x	x <- t(x)
258		}
259	292x	x
260		}

1		# StoppingOrdinal ----
2
3		#' @description `r lifecycle::badge("experimental")`
4		#' @inheritParams knit_print.StoppingTargetProb
5		#' @rdname knit_print
6		#' @export
7		#' @method knit_print StoppingOrdinal
8		knit_print.StoppingOrdinal <- function(
9		x,
10		...,
11		asis = TRUE
12		) {
13	2x	assert_flag(asis)
14
15	2x	rv <- paste0(
16	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
17	2x	"Based on a toxicity grade of ",
18	2x	x@grade,
19		": ",
20	2x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n")
21		)
22
23	2x	if (asis) {
24	!	rv <- knitr::asis_output(rv)
25		}
26	2x	rv
27		}
28
29		# StoppingMaxGainCIRatio ----
30
31		#' @description `r lifecycle::badge("experimental")`
32		#' @inheritParams knit_print.StoppingTargetProb
33		#' @rdname knit_print
34		#' @export
35		#' @method knit_print StoppingMaxGainCIRatio
36		knit_print.StoppingMaxGainCIRatio <- function(
37		x,
38		...,
39		asis = TRUE
40		) {
41	2x	assert_flag(asis)
42
43	2x	rv <- paste0(
44	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
45	2x	"If the ratio of the upper to the lower limit of the posterior 95% credible ",
46	2x	"interval for the probability of toxicity at the target dose (the smaller ",
47	2x	"of the MTD for ",
48	2x	100 * x@prob_target,
49	2x	"% target and GStar) is less than or equal to ",
50	2x	x@target_ratio,
51	2x	".\n\n"
52		)
53
54	2x	if (asis) {
55	!	rv <- knitr::asis_output(rv)
56		}
57	2x	rv
58		}
59
60		# StoppingList ----
61
62		#' @description `r lifecycle::badge("experimental")`
63		#' @inheritParams knit_print.StoppingTargetProb
64		#' @param preamble (`character`)\cr the text that introduces the list of rules
65		#' @param indent (`integer`)\cr the indent level of the current stopping rule
66		#' list. Spaces with length `indent * 4` will be prepended to the beginning of
67		#' the rendered stopping rule list.
68		#' @rdname knit_print
69		#' @export
70		#' @method knit_print StoppingList
71		knit_print.StoppingList <- function(
72		x,
73		...,
74		preamble,
75		indent = 0L,
76		asis = TRUE
77		) {
78	21x	assert_flag(asis)
79	21x	assert_integer(indent, lower = 0)
80
81	21x	if (missing(preamble)) {
82	5x	case_string <- switch(
83	5x	as.character(length(x@stop_list)),
84	5x	`1` = "rule ",
85	5x	"rules "
86		)
87	5x	preamble <- paste0(
88	5x	"If the result of applying the summary function to the following ",
89	5x	case_string,
90	5x	"is `TRUE`:\n"
91		)
92		} else {
93	16x	assert_character(preamble, len = 1, any.missing = FALSE)
94		}
95
96	21x	rules_list <- paste0(
97	21x	lapply(
98	21x	x@stop_list,
99	21x	function(z, indent) {
100	47x	paste0(
101	47x	strrep(" ", indent * 4),
102		"- ",
103	47x	knit_print(z, asis = FALSE, indent = indent + 1L, ...)
104		)
105		},
106	21x	indent = indent
107		),
108	21x	collapse = "\n"
109		)
110	21x	rv <- paste0(
111	21x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
112	21x	preamble,
113	21x	"\n",
114	21x	rules_list,
115	21x	"\n\n"
116		)
117
118	21x	if (asis) {
119	!	rv <- knitr::asis_output(rv)
120		}
121	21x	rv
122		}
123
124		# StoppingAny ----
125
126		#' @description `r lifecycle::badge("experimental")`
127		#' @inheritParams knit_print.StoppingList
128		#' @rdname knit_print
129		#' @export
130		#' @method knit_print StoppingAny
131		knit_print.StoppingAny <- function(
132		x,
133		...,
134		preamble,
135		asis = TRUE
136		) {
137	10x	if (missing(preamble)) {
138	10x	case_string <- switch(
139	10x	as.character(length(x@stop_list)),
140	10x	`1` = c("this ", "rule is "),
141	10x	`2` = c("either of the ", "rules are "),
142	10x	c("any of the ", "rules are ") # this works as default case
143		)
144	10x	preamble <- paste0(
145	10x	"If ",
146	10x	case_string[1],
147	10x	"following ",
148	10x	case_string[2],
149	10x	"`TRUE`:\n"
150		)
151		}
152	10x	knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
153		}
154
155		#' @description `r lifecycle::badge("experimental")`
156		#' @inheritParams knit_print.StoppingList
157		#' @rdname knit_print
158		#' @export
159		#' @method knit_print StoppingAll
160		knit_print.StoppingAll <- function(
161		x,
162		...,
163		preamble,
164		asis = TRUE
165		) {
166	6x	if (missing(preamble)) {
167	6x	case_string <- switch(
168	6x	as.character(length(x@stop_list)),
169	6x	`1` = c("this ", "rule is "),
170	6x	`2` = c("both of the ", "rules are "),
171	6x	c("all of the ", "rules are ") # this works as default case
172		)
173	6x	preamble <- paste0(
174	6x	"If ",
175	6x	case_string[1],
176	6x	"following ",
177	6x	case_string[2],
178	6x	"`TRUE`:\n"
179		)
180		}
181	6x	knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
182		}
183
184		# StoppingTDCIRatio ----
185
186		#' @description `r lifecycle::badge("experimental")`
187		#' @inheritParams knit_print.StoppingTargetProb
188		#' @rdname knit_print
189		#' @export
190		#' @method knit_print StoppingTDCIRatio
191		knit_print.StoppingTDCIRatio <- function(
192		x,
193		...,
194		dose_label = "the next best dose",
195		tox_label = "toxicity",
196		fmt_string = paste0(
197		"%sIf, at %s, the ratio of the upper to the lower limit of the posterior ",
198		"95%% credible interval for %s (targetting %2.0f%%) is less than or equal to "
199		),
200		asis = TRUE
201		) {
202	2x	assert_flag(asis)
203	2x	assert_character(fmt_string, len = 1, any.missing = FALSE)
204	2x	assert_character(tox_label, len = 1, any.missing = FALSE)
205	2x	assert_character(dose_label, len = 1, any.missing = FALSE)
206
207	2x	rv <- paste0(
208	2x	sprintf(
209	2x	fmt_string,
210	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
211	2x	dose_label,
212	2x	tox_label,
213	2x	100 * x@prob_target
214		),
215	2x	x@target_ratio,
216	2x	".\n\n"
217		)
218
219	2x	if (asis) {
220	!	rv <- knitr::asis_output(rv)
221		}
222	2x	rv
223		}
224
225		# StoppingTargetBiomarker ----
226
227		#' @description `r lifecycle::badge("experimental")`
228		#' @inheritParams knit_print.StoppingTargetProb
229		#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
230		#' @rdname knit_print
231		#' @export
232		#' @method knit_print StoppingTargetBiomarker
233		knit_print.StoppingTargetBiomarker <- function(
234		x,
235		...,
236		dose_label = "the next best dose",
237		biomarker_label = "the target biomarker",
238		fmt_string = paste0(
239		"%sIf, at %s, the posterior probability that %s is in the range ",
240		"(%.2f, %.2f)%s is %.0f%% or more.\n\n"
241		),
242		asis = TRUE
243		) {
244	4x	assert_flag(asis)
245	4x	assert_character(fmt_string, len = 1, any.missing = FALSE)
246	4x	assert_character(biomarker_label, len = 1, any.missing = FALSE)
247
248	4x	rv <- sprintf(
249	4x	fmt_string,
250	4x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
251	4x	dose_label,
252	4x	biomarker_label,
253	4x	x@target[1],
254	4x	x@target[2],
255	4x	ifelse(
256	4x	x@is_relative,
257	4x	paste0(", relative to the maximum value of ", biomarker_label, ","),
258		""
259		),
260	4x	100 * x@prob
261		)
262
263	4x	if (asis) {
264	!	rv <- knitr::asis_output(rv)
265		}
266	4x	rv
267		}
268
269		# StoppingLowestDoseHSRBeta ----
270
271		#' @description `r lifecycle::badge("experimental")`
272		#' @inheritParams knit_print.StoppingTargetProb
273		#' @rdname knit_print
274		#' @export
275		#' @method knit_print StoppingLowestDoseHSRBeta
276		knit_print.StoppingLowestDoseHSRBeta <- function(
277		x,
278		...,
279		tox_label = "toxicity",
280		fmt_string = paste0(
281		"%sIf, using a Hard Stopping Rule with a prior of Beta(%.0f, %.0f), the ",
282		"lowest dose in the dose grid has a posterior probability of %s of ",
283		"%.0f%% or more.\n\n"
284		),
285		asis = TRUE
286		) {
287	2x	assert_flag(asis)
288	2x	assert_character(fmt_string, len = 1, any.missing = FALSE)
289
290	2x	rv <- sprintf(
291	2x	fmt_string,
292	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
293	2x	x@a,
294	2x	x@b,
295	2x	tox_label,
296	2x	100 * x@prob
297		)
298
299	2x	if (asis) {
300	!	rv <- knitr::asis_output(rv)
301		}
302	2x	rv
303		}
304
305		# StoppingMTDCV ----
306
307		#' @description `r lifecycle::badge("experimental")`
308		#' @inheritParams knit_print.StoppingTargetProb
309		#' @rdname knit_print
310		#' @export
311		#' @method knit_print StoppingMTDCV
312		knit_print.StoppingMTDCV <- function(
313		x,
314		...,
315		fmt_string = paste0(
316		"%sIf the posterior estimate of the robust coefficient of variation of ",
317		"the MTD (targetting %2.0f%%), is than or equal to %.0f%%.\n\n"
318		),
319		asis = TRUE
320		) {
321	2x	assert_flag(asis)
322	2x	assert_character(fmt_string, len = 1, any.missing = FALSE)
323
324	2x	rv <- sprintf(
325	2x	fmt_string,
326	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
327	2x	100 * x@target,
328	2x	100 * x@thresh_cv
329		)
330
331	2x	if (asis) {
332	!	rv <- knitr::asis_output(rv)
333		}
334	2x	rv
335		}
336
337		# StoppingMTDdistribution ----
338
339		#' @description `r lifecycle::badge("experimental")`
340		#' @inheritParams knit_print.StoppingTargetProb
341		#' @rdname knit_print
342		#' @export
343		#' @method knit_print StoppingMTDdistribution
344		knit_print.StoppingMTDdistribution <- function(
345		x,
346		...,
347		fmt_string = "%sIf the mean posterior probability of %s at %.0f%% of %s is at least %4.2f.\n\n",
348		dose_label = "the next best dose",
349		tox_label = "toxicity",
350		asis = TRUE
351		) {
352	2x	assert_flag(asis)
353	2x	assert_character(dose_label, len = 1, any.missing = FALSE)
354	2x	assert_character(tox_label, len = 1, any.missing = FALSE)
355	2x	assert_character(fmt_string, len = 1, any.missing = FALSE)
356
357	2x	rv <- sprintf(
358	2x	fmt_string,
359	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
360	2x	tox_label,
361	2x	100 * x@thresh,
362	2x	dose_label,
363	2x	x@prob
364		)
365
366	2x	if (asis) {
367	!	rv <- knitr::asis_output(rv)
368		}
369	2x	rv
370		}
371
372		# StoppingHighestDose ----
373
374		#' @description `r lifecycle::badge("experimental")`
375		#' @param asis (`flag`)\cr Not used at present
376		#' @rdname knit_print
377		#' @export
378		#' @method knit_print StoppingHighestDose
379		knit_print.StoppingHighestDose <- function(
380		x,
381		...,
382		dose_label = "the highest dose in the dose grid",
383		asis = TRUE
384		) {
385	2x	rv <- paste0(
386	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
387	2x	"If the next best dose is ",
388	2x	dose_label,
389	2x	".\n\n"
390		)
391
392	2x	if (asis) {
393	!	rv <- knitr::asis_output(rv)
394		}
395	2x	rv
396		}
397
398		# StoppingSpecificDose ----
399
400		#' @description `r lifecycle::badge("experimental")`
401		#' @param asis (`flag`)\cr Not used at present
402		#' @inheritParams knit_print.StoppingTargetProb
403		#' @rdname knit_print
404		#' @export
405		#' @method knit_print StoppingSpecificDose
406		knit_print.StoppingSpecificDose <- function(
407		x,
408		...,
409		dose_label = as.character(x@dose),
410		asis = TRUE
411		) {
412	2x	x@rule@report_label <- x@report_label
413	2x	knit_print(
414	2x	x@rule,
415		...,
416	2x	dose_label = dose_label,
417	2x	asis = asis
418		)
419		}
420
421		# StoppingTargetProb ----
422
423		#' @description `r lifecycle::badge("experimental")`
424		#' @param asis (`flag`)\cr Not used at present
425		#' @param fmt_string (`character`)\cr the character string that defines the format
426		#' of the output
427		#' @param dose_label (`character`)\cr the term used to describe the target dose
428		#' @param tox_label (`character`)\cr the term used to describe toxicity
429		#' @rdname knit_print
430		#' @export
431		#' @method knit_print StoppingTargetProb
432		knit_print.StoppingTargetProb <- function(
433		x,
434		...,
435		fmt_string = paste0(
436		"%sIf the probability of %s at %s is in the range [%4.2f, %4.2f] ",
437		"is at least %4.2f.\n\n"
438		),
439		dose_label = "the next best dose",
440		tox_label = "toxicity",
441		asis = TRUE
442		) {
443	20x	assert_flag(asis)
444	20x	assert_character(dose_label, len = 1, any.missing = FALSE)
445	20x	assert_character(tox_label, len = 1, any.missing = FALSE)
446	20x	assert_character(fmt_string, len = 1, any.missing = FALSE)
447
448	20x	rv <- sprintf(
449	20x	fmt_string,
450	20x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
451	20x	tox_label,
452	20x	dose_label,
453	20x	x@target[1],
454	20x	x@target[2],
455	20x	x@prob
456		)
457
458	20x	if (asis) {
459	!	rv <- knitr::asis_output(rv)
460		}
461	20x	rv
462		}
463
464		# StoppingMinCohorts ----
465
466		#' @description `r lifecycle::badge("experimental")`
467		#' @param asis (`flag`)\cr Not used at present
468		#' @rdname knit_print
469		#' @export
470		#' @method knit_print StoppingMinCohorts
471		knit_print.StoppingMinCohorts <- function(
472		x,
473		...,
474		asis = TRUE
475		) {
476	17x	assert_flag(asis)
477
478	17x	rv <- paste0(
479	17x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
480	17x	"If ",
481	17x	x@nCohorts,
482	17x	" or more cohorts have been treated.\n\n"
483		)
484	17x	if (asis) {
485	!	rv <- knitr::asis_output(rv)
486		}
487	17x	rv
488		}
489
490		# StoppingMinPatients ----
491
492		#' @description `r lifecycle::badge("experimental")`
493		#' @param label (`character`)\cr the term used to label participants
494		#' @param asis (`flag`)\cr Not used at present
495		#' @rdname knit_print
496		#' @export
497		#' @method knit_print StoppingMinPatients
498		knit_print.StoppingMinPatients <- function(
499		x,
500		...,
501		label = "participant",
502		asis = TRUE
503		) {
504	22x	assert_flag(asis)
505	22x	label <- h_prepare_labels(label)
506
507	22x	rv <- paste0(
508	22x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
509	22x	"If ",
510	22x	x@nPatients,
511	22x	paste0(" or more ", label[2], " have been treated."),
512	22x	"\n\n"
513		)
514	22x	if (asis) {
515	!	rv <- knitr::asis_output(rv)
516		}
517	22x	rv
518		}
519
520		# StoppingPatientsNearDose ----
521
522		#' @description `r lifecycle::badge("experimental")`
523		#' @param label (`character`)\cr the term used to label participants
524		#' @inheritParams knit_print.StoppingTargetProb
525		#' @param asis (`flag`)\cr Not used at present
526		#' @rdname knit_print
527		#' @export
528		#' @method knit_print StoppingPatientsNearDose
529		knit_print.StoppingPatientsNearDose <- function(
530		x,
531		...,
532		dose_label = "the next best dose",
533		label = "participants",
534		asis = TRUE
535		) {
536	2x	assert_flag(asis)
537	2x	assert_character(label, len = 1, any.missing = FALSE)
538	2x	assert_character(dose_label, len = 1, any.missing = FALSE)
539
540	2x	rv <- paste0(
541	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
542	2x	"If ",
543	2x	x@nPatients,
544	2x	paste0(" or more ", label, " have been treated "),
545	2x	ifelse(
546	2x	x@percentage == 0,
547	2x	"at ",
548	2x	paste0("within ", x@percentage, "% of ")
549		),
550	2x	dose_label,
551	2x	".\n\n"
552		)
553	2x	if (asis) {
554	!	rv <- knitr::asis_output(rv)
555		}
556	2x	rv
557		}
558
559		# StoppingCohortsNearDose ----
560
561		#' @description `r lifecycle::badge("experimental")`
562		#' @param asis (`flag`)\cr Not used at present
563		#' @inheritParams knit_print.StoppingTargetProb
564		#' @rdname knit_print
565		#' @export
566		#' @method knit_print StoppingCohortsNearDose
567		knit_print.StoppingCohortsNearDose <- function(
568		x,
569		...,
570		dose_label = "the next best dose",
571		asis = TRUE
572		) {
573	2x	assert_flag(asis)
574	2x	assert_character(dose_label, len = 1, any.missing = FALSE)
575
576	2x	rv <- paste0(
577	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
578	2x	"If ",
579	2x	x@nCohorts,
580	2x	" or more cohorts have been treated ",
581	2x	ifelse(
582	2x	x@percentage == 0,
583	2x	"at ",
584	2x	paste0("within ", x@percentage, "% of ")
585		),
586	2x	dose_label,
587	2x	".\n\n"
588		)
589
590	2x	if (asis) {
591	!	rv <- knitr::asis_output(rv)
592		}
593	2x	rv
594		}
595
596		# StoppingMissingDose ----
597
598		#' @description `r lifecycle::badge("experimental")`
599		#' @param asis (`flag`)\cr Not used at present
600		#' @rdname knit_print
601		#' @export
602		#' @method knit_print StoppingMissingDose
603		knit_print.StoppingMissingDose <- function(
604		x,
605		...,
606		asis = TRUE
607		) {
608	2x	assert_flag(asis)
609
610	2x	rv <- paste0(
611	2x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
612	2x	"If the dose returned by <code>nextBest()</code> is ",
613	2x	"<code>NA</code>, or if the trial includes a placebo dose, the placebo dose.\n\n"
614		)
615
616	2x	if (asis) {
617	!	rv <- knitr::asis_output(rv)
618		}
619	2x	rv
620		}

1		#' Helper Function to Set and Save the RNG Seed
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' This code is basically copied from `stats:::simulate.lm`.
6		#'
7		#' @param seed an object specifying if and how the random number generator
8		#' should be initialized ("seeded"). Either `NULL` (default) or an
9		#' integer that will be used in a call to [set.seed()] before
10		#' simulating the response vectors. If set, the value is saved as the
11		#' `seed` slot of the returned object. The default, `NULL` will
12		#' not change the random generator state.
13		#' @return The integer vector containing the random number generate state will
14		#' be returned, in order to call this function with this input to reproduce
15		#' the obtained simulation results.
16		#'
17		#' @export
18		set_seed <- function(seed = NULL) {
19	5x	assert_number(seed, null.ok = TRUE)
20
21	5x	if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
22	1x	runif(1)
23		}
24
25	5x	if (is.null(seed)) {
26	2x	get(".Random.seed", envir = .GlobalEnv)
27		} else {
28	3x	seed <- as.integer(seed)
29	3x	r_seed <- get(".Random.seed", envir = .GlobalEnv)
30		# Make sure r_seed exists in parent frame.
31	3x	assign(".r_seed", r_seed, envir = parent.frame())
32	3x	set.seed(seed)
33		# Here we need the r_seed in the parent.frame!
34	3x	do.call(
35	3x	"on.exit",
36	3x	list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))),
37	3x	envir = parent.frame()
38		)
39	3x	structure(seed, kind = as.list(RNGkind()))
40		}
41		}
42
43		#' Helper Function to Obtain Simulation Results List
44		#'
45		#' The function `fun` can use variables that are visible to itself.
46		#' The names of these variables have to be given in the vector `vars`.
47		#'
48		#' @param fun (`function`)\cr the simulation function for a single iteration, which takes as
49		#' single parameter the iteration index.
50		#' @param nsim number of simulations to be conducted.
51		#' @param vars names of the variables.
52		#' @param parallel should the simulation runs be parallelized across the
53		#' clusters of the computer?
54		#' @param n_cores how many cores should be used for parallel computing?
55		#' @return The list with all simulation results (one iteration corresponds
56		#' to one list element).
57		#'
58		#' @importFrom parallel makeCluster
59		#' @importFrom parallelly availableCores
60		#' @keywords internal programming
61		get_result_list <- function(
62		fun,
63		nsim,
64		vars,
65		parallel,
66		n_cores
67		) {
68	5x	assert_flag(parallel)
69	4x	assert_integerish(n_cores, lower = 1)
70
71	3x	if (!parallel) {
72	3x	lapply(
73	3x	X = seq_len(nsim),
74	3x	FUN = fun
75		)
76		} else {
77		# Process all simulations.
78	!	cores <- min(
79	!	as.integer(n_cores),
80	!	parallelly::availableCores()
81		)
82
83		# Start the cluster.
84	!	cl <- parallel::makeCluster(cores)
85
86		# Load the required R package.
87	!	parallel::clusterEvalQ(cl, {
88	!	library(crmPack)
89	!	NULL
90		})
91
92		# Export local variables from the caller environment.
93		# Note: parent.frame() is different from parent.env() which returns
94		# the environment where this function has been defined!
95	!	parallel::clusterExport(
96	!	cl = cl,
97	!	varlist = vars,
98	!	envir = parent.frame()
99		)
100
101		# Export all global variables.
102	!	parallel::clusterExport(
103	!	cl = cl,
104	!	varlist = ls(.GlobalEnv)
105		)
106
107		# Load user extensions from global options.
108	!	crmpack_extensions <- getOption("crmpack_extensions")
109	!	if (is.null(crmpack_extensions) != TRUE) {
110	!	tryCatch(
111		{
112	!	parallel::clusterCall(cl, crmpack_extensions)
113		},
114	!	error = function(e) {
115	!	stop("Failed to export crmpack_extensions: ", e$message)
116		}
117		)
118		}
119
120		# Do the computations in parallel.
121	!	res <- parallel::parLapply(
122	!	cl = cl,
123	!	X = seq_len(nsim),
124	!	fun = fun
125		)
126
127		# Stop the cluster.
128	!	parallel::stopCluster(cl)
129
130	!	res
131		}
132		}
133
134
135		#' Helper Function to call truth calculation
136		#'
137		#' @param dose (`number`)\cr current dose.
138		#' @param truth (`function`)\cr defines the true probability for a DLT at a dose.
139		#' @param this_args (`data.frame`)\cr list of arguments for the truth.
140		#' @return The updated `this_truth`.
141		#'
142		#' @keywords internal
143		h_this_truth <- function(dose, this_args, truth) {
144	1x	do.call(
145	1x	truth,
146		## First argument: the dose
147	1x	c(
148	1x	dose,
149		## Following arguments
150	1x	this_args
151		)
152		)
153		}
154
155
156		#' Helper Function to create return list for Simulations output
157		#'
158		#' @param resultList (`list`)\cr raw iteration output.
159		#'
160		#' @return aggregated output for simulation object `list`.
161		#'
162		#' @keywords internal
163		h_simulations_output_format <- function(resultList) {
164		## put everything in the Simulations format:
165
166		## setup the list for the simulated data objects
167	1x	dataList <- lapply(resultList, "[[", "data")
168
169		## the vector of the final dose recommendations
170	1x	recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))
171
172		## setup the list for the final fits
173	1x	fitList <- lapply(resultList, "[[", "fit")
174
175		## the reasons for stopping
176	1x	stopReasons <- lapply(resultList, "[[", "stop")
177
178		# individual stopping rule results as matrix, labels as column names
179	1x	stopResults <- lapply(resultList, "[[", "report_results")
180	1x	stop_matrix <- as.matrix(do.call(rbind, stopResults))
181
182		# Result list of additional statistical summary.
183	1x	additional_stats <- lapply(resultList, "[[", "additional_stats")
184
185	1x	list(
186	1x	dataList = dataList,
187	1x	recommendedDoses = recommendedDoses,
188	1x	fitList = fitList,
189	1x	stopReasons = stopReasons,
190	1x	stopResults = stopResults,
191	1x	additional_stats = additional_stats,
192	1x	stop_matrix = stop_matrix
193		)
194		}
195
196
197		#' Helper function to recursively unpack stopping rules and return lists with
198		#' logical value and label given
199		#'
200		#' @param stopit_tree object from simulate method
201		#' @return named list
202
203		h_unpack_stopit <- function(stopit_tree) {
204	27x	label <- attr(stopit_tree, "report_label")
205	27x	value <- stopit_tree[1]
206	27x	names(value) <- label
207	27x	value
208	27x	if (is.null(attr(stopit_tree, "individual"))) {
209	19x	value
210		} else {
211	8x	unlist(c(
212	8x	value,
213	8x	lapply(attr(stopit_tree, "individual"), h_unpack_stopit)
214		))
215		}
216		}
217
218
219		#' Helper function to determine the dlts including first separate and placebo
220		#' condition
221		#'
222		#' @param data (`Data`)\cr what data to start from.
223		#' @param dose (`number`)\cr current dose.
224		#' @param prob (`function`)\cr defines the true probability for a DLT at a dose.
225		#' @param prob_placebo (`function`)\cr defines the true probability for a DLT at a placebo condition.
226		#' @param cohort_size (`number`)\cr the cohort size to use.
227		#' @param cohort_size_placebo (`number`)\cr the cohort size to use for placebo condition.
228		#' @param dose_grid (`numeric`)\cr the dose_grid as specified by the user.
229		#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
230		#' @return updated data object
231		#' @keywords internal
232
233		h_determine_dlts <- function(
234		data,
235		dose,
236		prob,
237		prob_placebo,
238		cohort_size,
239		cohort_size_placebo,
240		dose_grid,
241		first_separate
242		) {
243	4x	assert_class(data, "Data")
244	4x	assert_number(dose)
245	4x	assert_number(prob)
246	4x	assert_number(cohort_size)
247	4x	assert_flag(first_separate)
248
249	4x	if (first_separate && cohort_size > 1) {
250	2x	dlts <- rbinom(n = 1, size = 1, prob = prob)
251	2x	if ((data@placebo) && cohort_size_placebo > 0) {
252	!	dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
253		}
254	2x	if (dlts == 0) {
255	1x	dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
256	1x	if ((data@placebo) && cohort_size_placebo > 0) {
257	!	dlts_placebo <- c(
258	!	dlts_placebo,
259	!	rbinom(
260	!	n = cohort_size_placebo, # cohort_size_placebo - 1?
261	!	size = 1,
262	!	prob = prob_placebo
263		)
264		)
265		}
266		}
267		} else {
268	2x	dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
269	2x	if ((data@placebo) && cohort_size_placebo > 0) {
270	1x	dlts_placebo <- rbinom(
271	1x	n = cohort_size_placebo,
272	1x	size = 1,
273	1x	prob = prob_placebo
274		)
275		}
276		}
277
278	4x	if ((data@placebo) && cohort_size_placebo > 0) {
279	1x	this_data <- update(
280	1x	object = data,
281	1x	x = dose_grid,
282	1x	y = dlts_placebo,
283	1x	check = FALSE
284		)
285
286		## update the data with active dose
287	1x	this_data <- update(
288	1x	object = this_data,
289	1x	x = dose,
290	1x	y = dlts,
291	1x	new_cohort = FALSE
292		)
293		} else {
294		## update the data with this cohort
295	3x	this_data <- update(
296	3x	object = data,
297	3x	x = dose,
298	3x	y = dlts
299		)
300		}
301	4x	this_data
302		}

1		#' Internal Helper Functions for Validation of [`GeneralData`] Objects
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' These functions are only used internally to validate the format of an input
6		#' [`GeneralData`] or inherited classes and therefore not exported.
7		#'
8		#' @name v_data_objects
9		#' @param object (`GeneralData`)\cr object to validate.
10		#' @return A `character` vector with the validation failure messages,
11		#' or `TRUE` in case validation passes.
12		NULL
13
14		#' @describeIn v_data_objects validates that the [`GeneralData`]
15		#' object contains unique `ID`, non-negative `cohort` indices and
16		#' `ID` and `cohort` vectors are of the same length `nObs`.
17		v_general_data <- function(object) {
18	2x	v <- Validate()
19		# In if clause so that below test_* won't fail.
20	2x	if (!test_int(object@nObs)) {
21	!	return("nObs must be of type integer of length 1")
22		}
23	2x	v$check(
24	2x	test_integer(
25	2x	object@ID,
26	2x	len = object@nObs,
27	2x	any.missing = FALSE,
28	2x	unique = TRUE,
29	2x	null.ok = TRUE
30		),
31	2x	"ID must be of type integer and length nObs and unique"
32		)
33	2x	v$check(
34	2x	test_integer(
35	2x	object@cohort,
36	2x	lower = 0L,
37	2x	len = object@nObs,
38	2x	any.missing = FALSE,
39	2x	sorted = TRUE
40		),
41	2x	"cohort must be of type integer and length nObs and contain non-negative, sorted values"
42		)
43	2x	v$result()
44		}
45
46		#' @describeIn v_data_objects helper function which verifies whether
47		#' the `dose` values are unique in each and every different `cohort`.
48		#' @param dose (`numeric`)\cr dose values.
49		#' @param cohort (`integer`)\cr cohort indices parallel to `doses`.
50		#' @return `TRUE` if `dose` is unique per `cohort`, otherwise `FALSE`.
51		h_doses_unique_per_cohort <- function(dose, cohort) {
52	577x	assert_numeric(dose)
53	577x	assert_integer(cohort)
54
55	577x	num_doses_per_cohort <- tapply(
56	577x	X = dose,
57	577x	INDEX = cohort,
58	577x	FUN = function(d) length(unique(d))
59		)
60	577x	all(num_doses_per_cohort == 1L)
61		}
62
63		#' Helper Function performing validation Common to Data and DataOrdinal
64		#'
65		#' @rdname h_validate_common_data_slots
66		#' @param object (`Data` or `DataOrdinal`)\cr the object to be validated
67		#' @returns a `Validate` object containing the result of the validation
68		h_validate_common_data_slots <- function(object) {
69	811x	v <- Validate()
70	811x	v$check(
71	811x	test_double(object@x, len = object@nObs, any.missing = FALSE),
72	811x	"Doses vector x must be of type double and length nObs"
73		)
74	811x	v$check(
75	811x	test_double(
76	811x	object@doseGrid,
77	811x	len = object@nGrid,
78	811x	any.missing = FALSE,
79	811x	unique = TRUE,
80	811x	sorted = TRUE
81		),
82	811x	"doseGrid must be of type double and length nGrid and contain unique, sorted values"
83		)
84	811x	v$check(
85	811x	test_int(object@nGrid),
86	811x	"Number of dose grid values nGrid must be scalar integer"
87		)
88	811x	v$check(
89	811x	test_integer(object@xLevel, len = object@nObs, any.missing = FALSE),
90	811x	"Levels xLevel for the doses the patients have been given must be of type integer and length nObs"
91		)
92	811x	v$check(
93	811x	test_flag(object@placebo),
94	811x	"The placebo flag must be scalar logical"
95		)
96	811x	v$check(
97	811x	test_subset(object@x, object@doseGrid),
98	811x	"Dose values in x must be from doseGrid"
99		)
100	811x	v$check(
101	811x	h_all_equivalent(object@x, object@doseGrid[object@xLevel]),
102	811x	"x must be equivalent to doseGrid[xLevel] (up to numerical tolerance)"
103		)
104	811x	if (!object@placebo) {
105	575x	v$check(
106	575x	h_doses_unique_per_cohort(dose = object@x, cohort = object@cohort),
107	575x	"There must be only one dose level per cohort"
108		)
109		}
110	811x	v
111		}
112
113		#' @describeIn v_data_objects validates that the [`Data`] object contains
114		#' valid elements with respect to their types, dependency and length.
115		v_data <- function(object) {
116	3x	v <- h_validate_common_data_slots(object)
117	3x	v$check(
118	3x	test_integer(
119	3x	object@y,
120	3x	lower = 0,
121	3x	upper = 1,
122	3x	len = object@nObs,
123	3x	any.missing = FALSE
124		),
125	3x	"DLT vector y must be nObs long and contain 0 or 1 integers only"
126		)
127
128	3x	v$result()
129		}
130
131		#' @describeIn v_data_objects validates that the [`DataDual`] object
132		#' contains valid biomarker vector with respect to its type and the length.
133		v_data_dual <- function(object) {
134	2x	v <- Validate()
135	2x	v$check(
136	2x	test_double(object@w, len = object@nObs, any.missing = FALSE),
137	2x	"Biomarker vector w must be of type double and length nObs"
138		)
139	2x	v$result()
140		}
141
142		#' @describeIn v_data_objects validates that the [`DataParts`] object
143		#' contains valid elements with respect to their types, dependency and length.
144		v_data_parts <- function(object) {
145	5x	v <- Validate()
146	5x	v$check(
147	5x	test_integer(
148	5x	object@part,
149	5x	lower = 1,
150	5x	upper = 2,
151	5x	len = object@nObs,
152	5x	any.missing = FALSE
153		),
154	5x	"vector part must be nObs long and contain 1 or 2 integers only"
155		)
156	5x	v$check(
157	5x	test_int(object@nextPart, lower = 1, upper = 2),
158	5x	"nextPart must be integer scalar 1 or 2"
159		)
160	5x	v$check(
161	5x	test_numeric(
162	5x	object@part1Ladder,
163	5x	any.missing = FALSE,
164	5x	sorted = TRUE,
165	5x	unique = TRUE
166		),
167	5x	"part1Ladder must be of type double and contain unique, sorted values"
168		)
169	5x	v$check(
170	5x	test_subset(object@part1Ladder, object@doseGrid),
171	5x	"part1Ladder must have all entries from doseGrid"
172		)
173	5x	v$result()
174		}
175
176		#' @describeIn v_data_objects validates that the [`DataMixture`] object
177		#' contains valid elements with respect to their types, dependency and length.
178		v_data_mixture <- function(object) {
179	5x	v <- Validate()
180
181		# In if clause so that below test_* won't fail.
182	5x	if (!test_int(object@nObsshare)) {
183	1x	return("nObsshare must be of type integer of length 1")
184		}
185	4x	v$check(
186	4x	test_numeric(object@xshare, len = object@nObsshare, any.missing = FALSE),
187	4x	"Dose vector xshare must be of type double and length nObsshare"
188		)
189	4x	v$check(
190	4x	test_integer(
191	4x	object@yshare,
192	4x	lower = 0,
193	4x	upper = 1,
194	4x	len = object@nObsshare,
195	4x	any.missing = FALSE
196		),
197	4x	"DLT vector yshare must be nObsshare long and contain 0 or 1 integers only"
198		)
199	4x	v$check(
200	4x	test_subset(object@xshare, object@doseGrid),
201	4x	"Dose values in xshare must be from doseGrid"
202		)
203	4x	v$result()
204		}
205
206		#' @describeIn v_data_objects validates that the [`DataDA`] object
207		#' contains valid elements with respect to their types, dependency and length.
208		v_data_da <- function(object) {
209	4x	v <- Validate()
210		# In if clause so that below test_* won't fail.
211	4x	if (!(test_number(object@Tmax) && object@Tmax > 0)) {
212	1x	return(
213	1x	"DLT window Tmax must be of type double of length 1 and greater than 0"
214		)
215		}
216	3x	v$check(
217	3x	test_numeric(
218	3x	object@u,
219	3x	upper = object@Tmax,
220	3x	len = object@nObs,
221	3x	any.missing = FALSE
222		) &&
223	3x	all(object@u >= 0),
224	3x	"u must be of type double, nObs length, non-negative, not missing and not greater than Tmax"
225		)
226	3x	v$check(
227	3x	test_numeric(
228	3x	object@t0,
229	3x	lower = 0,
230	3x	len = object@nObs,
231	3x	any.missing = FALSE,
232	3x	sorted = TRUE
233		),
234	3x	"t0 must be of type double, nObs length, sorted non-negative"
235		)
236	3x	v$result()
237		}
238
239		#' @describeIn v_data_objects validates that the [`DataOrdinal`] object
240		#' contains valid elements with respect to their types, dependency and length.
241		v_data_ordinal <- function(object) {
242	8x	v <- h_validate_common_data_slots(object)
243	8x	v$check(
244	8x	test_integer(
245	8x	object@y,
246	8x	lower = 0,
247	8x	upper = length(object@yCategories) - 1,
248	8x	len = object@nObs,
249	8x	any.missing = FALSE
250		),
251	8x	"DLT vector y must be nObs long and contain integers between 0 and k-1 only, where k is the length of the vector in the yCategories slot" # nolint
252		)
253	8x	v$check(
254	8x	length(unique(names(object@yCategories))) ==
255	8x	length(names(object@yCategories)),
256	8x	"yCategory labels must be unique"
257		)
258	8x	v$result()
259		}
260
261		#' @describeIn v_data_objects validates that the [`DataGrouped`] object
262		#' contains valid group information.
263		v_data_grouped <- function(object) {
264	3x	v <- Validate()
265	3x	v$check(
266	3x	test_factor(
267	3x	object@group,
268	3x	levels = c("mono", "combo"),
269	3x	len = object@nObs,
270	3x	any.missing = FALSE
271		),
272	3x	"group must be factor with levels mono and combo of length nObs without missings"
273		)
274	3x	v$result()
275		}

1		#' Update [`DualEndpoint`] class model components with regard to biomarker
2		#' regression variance.
3		#'
4		#' @description `r lifecycle::badge("stable")`
5		#'
6		#' A simple helper function that takes [`DualEndpoint`] model existing components
7		#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
8		#' to biomarker regression variance `sigma2W`.
9		#'
10		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for the biomarker
11		#' regression variance `sigma2W` should be used or not. If `sigma2W` is not
12		#' supposed to be a fixed value, a prior distribution from the Inverse-Gamma
13		#' distribution will be used. See the details below, under `sigma2W` argument.
14		#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
15		#' Inverse-Gamma distribution parameters, i.e. vector with two elements named
16		#' `a` and `b`.
17		#' @param comp (`list`)\cr a named list with model components that will be updated.
18		#' The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
19		#' definitions of the components, see [`GeneralModel`] class.
20		#' The `modelspecs` and `init` components on `comp` list are specified up to
21		#' the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
22		#' functions. These bodies are simply a lists itself.
23		#'
24		#' @return `list` with updated model components.
25		#'
26		#' @export
27		h_model_dual_endpoint_sigma2w <- function(
28		use_fixed, # nolintr
29		sigma2W,
30		comp
31		) {
32	182x	if (use_fixed) {
33	106x	assert_number(sigma2W, lower = 0 + .Machine$double.xmin, finite = TRUE)
34	104x	comp$modelspecs$precW <- 1 / sigma2W
35		} else {
36	76x	assert_true(h_test_named_numeric(sigma2W, permutation.of = c("a", "b")))
37	75x	comp$priormodel <- h_jags_join_models(
38	75x	comp$priormodel,
39	75x	function() {
40	!	precW ~ dgamma(precWa, precWb)
41		}
42		)
43	75x	comp$modelspecs$precWa <- sigma2W[["a"]]
44	75x	comp$modelspecs$precWb <- sigma2W[["b"]]
45	75x	comp$init$precW <- 1
46	75x	comp$sample <- c(comp$sample, "precW")
47		}
48	179x	comp
49		}
50
51		#' Update [`DualEndpoint`] class model components with regard to DLT and biomarker
52		#' correlation.
53		#'
54		#' @description `r lifecycle::badge("stable")`
55		#'
56		#' A simple helper function that takes [`DualEndpoint`] model existing components
57		#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
58		#' DLT and biomarker correlation `rho`.
59		#'
60		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for DLT and
61		#' biomarker correlation `rho` should be used or not. If `rho` is not supposed
62		#' to be a fixed value, a prior distribution from the scaled Beta family will
63		#' be used. See the details below, under `rho` argument.
64		#' @param rho (`numeric`)\cr DLT and biomarker correlation. It must be either a
65		#' fixed value (between `-1` and `1`), or a named vector with two elements,
66		#' named `a` and `b` for the Beta prior on the transformation
67		#' `kappa = (rho + 1) / 2`, which is in `(0, 1)`. For example, `a = 1, b = 1`
68		#' leads to a uniform prior on `rho`.
69		#' @param comp (`list`)\cr a named list with model components that will be updated.
70		#' The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
71		#' definitions of the components, see [`GeneralModel`] class.
72		#' The `modelspecs` and `init` components on `comp` list are specified up to
73		#' the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
74		#' functions. These bodies are simply a lists itself.
75		#'
76		#' @return A `list` with updated model components.
77		#'
78		#' @export
79		h_model_dual_endpoint_rho <- function(use_fixed, rho, comp) {
80	183x	rmin <- .Machine$double.xmin
81	183x	if (use_fixed) {
82	107x	assert_number(rho, lower = -1 + rmin, upper = 1 - rmin)
83	104x	comp$modelspecs$rho <- rho
84		} else {
85	76x	assert_true(h_test_named_numeric(rho, permutation.of = c("a", "b")))
86	75x	comp$priormodel <- h_jags_join_models(
87	75x	comp$priormodel,
88	75x	function() {
89	!	kappa ~ dbeta(rhoa, rhob)
90	!	rho <- 2 * kappa - 1
91		}
92		)
93	75x	comp$modelspecs$rhoa <- rho[["a"]]
94	75x	comp$modelspecs$rhob <- rho[["b"]]
95	75x	comp$init$kappa <- 0.5
96	75x	comp$sample <- c(comp$sample, "rho")
97		}
98	179x	comp
99		}
100
101		#' Update certain components of [`DualEndpoint`] model with regard to prior variance
102		#' factor of the random walk.
103		#'
104		#' @description `r lifecycle::badge("stable")`
105		#'
106		#' A simple helper function that takes [`DualEndpoint`] object and updates
107		#' `priormodel`, `modelspecs`, `init`, `sample` slots according to the random walk
108		#' variance.
109		#'
110		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for
111		#' `sigma2betaW` should be used or not. If `sigma2betaW` is not supposed
112		#' to be a fixed value, a prior distribution from the Inverse-Gamma distribution
113		#' will be used. See the details below, under `sigma2betaW` argument.
114		#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
115		#' prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
116		#' parameters, i.e. vector with two elements named `a` and `b`.
117		#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
118		#'
119		#' @return A [`DualEndpoint`] model with updated `priormodel`, `modelspecs`,
120		#' `init`, `sample` slots.
121		#'
122		#' @seealso [`DualEndpointRW`].
123		#' @export
124		h_model_dual_endpoint_sigma2betaw <- function(
125		use_fixed, # nolintr
126		sigma2betaW,
127		de
128		) {
129	43x	modelspecs <- de@modelspecs
130	43x	init <- de@init
131
132	43x	if (use_fixed) {
133	31x	assert_number(sigma2betaW, lower = 0 + .Machine$double.xmin, finite = TRUE)
134	29x	ms <- list(precBetaW = 1 / sigma2betaW)
135		} else {
136	12x	assert_true(h_test_named_numeric(sigma2betaW, permutation.of = c("a", "b")))
137		# gamma prior for random walk precision.
138	11x	de@priormodel <- h_jags_join_models(
139	11x	de@priormodel,
140	11x	function() {
141	!	precBetaW ~ dgamma(precBetaWa, precBetaWb)
142		}
143		)
144	11x	ms <- list(precBetaWa = sigma2betaW[["a"]], precBetaWb = sigma2betaW[["b"]])
145	11x	de@init <- function(y) {
146	10x	c(init(y), list(precBetaW = 1))
147		}
148	11x	de@sample <- c(de@sample, "precBetaW")
149		}
150	40x	de@modelspecs <- function(from_prior) {
151	24x	c(modelspecs(from_prior), ms)
152		}
153	40x	de
154		}
155
156		#' Update certain components of [`DualEndpoint`] model with regard to parameters
157		#' of the function that models dose-biomarker relationship defined in the
158		#' [`DualEndpointBeta`] class.
159		#'
160		#' @description `r lifecycle::badge("stable")`
161		#'
162		#' A simple helper function that takes [`DualEndpoint`] object and updates
163		#' `use_fixed`, `priormodel`, `modelspecs`, `init`, `sample` slots with regard
164		#' to a given parameter of the dose-biomarker relationship \eqn{f(x)} defined in
165		#' the [`DualEndpointBeta`] class. This update solely depends on whether a given
166		#' parameter's value `param` is a fixed-valued scalar or two-elements numeric
167		#' vector. In the later case, it is assumed that `param` represents two
168		#' parameters of a probability distribution that will be used in `priormodel`
169		#' function to generate values for the `param_name` parameter of \eqn{f(x)}.
170		#' See the help page for [`DualEndpointBeta`] class for more details.
171		#'
172		#' @param param (`numeric`)\cr the value of a given `param_name` parameter of
173		#' the dose-biomarker relationship function \eqn{f(x)}. Either a fixed-valued
174		#' scalar or vector with two elements that are the parameters of a probability
175		#' distribution that will be used in `priormodel` function to generate values
176		#' for the `param_name` parameter of \eqn{f(x)}.
177		#' @param param_name (`string`)\cr the name of the parameter of \eqn{f(x)},
178		#' whose value depends on `param`.
179		#' @param param_suffix (`character`)\cr the two suffixes to be appended to
180		#' the elements of `param_name` and then used when updating `modelspecs`.
181		#' The value of this argument is ignored when `param` is a scalar.
182		#' @param priormodel (`function` or `NULL`)\cr a function representing the
183		#' `JAGS` prior specification that will be appended to existing
184		#' `de@priormodel` specification if `param` is not a scalar. Otherwise,
185		#' `de@priormodel` remains unchanged.
186		#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
187		#'
188		#' @return A [`DualEndpoint`] model with updated `use_fixed`, `priormodel`,
189		#' `modelspecs`, `init`, `sample` slots.
190		#'
191		#' @export
192		h_model_dual_endpoint_beta <- function(
193		param,
194		param_name,
195		param_suffix = c("_low", "_high"),
196		priormodel = NULL,
197		de
198		) {
199	161x	assert_numeric(param, min.len = 1, max.len = 2, any.missing = FALSE)
200	160x	assert_string(param_name)
201	159x	assert_class(de, "DualEndpoint")
202
203	159x	use_fixed <- setNames(test_number(param), param_name)
204	159x	modelspecs <- de@modelspecs
205	159x	init <- de@init
206
207	159x	if (use_fixed) {
208	79x	ms <- setNames(list(param), param_name)
209		} else {
210	80x	assert_character(param_suffix, len = 2, unique = TRUE, any.missing = FALSE)
211	79x	assert_function(priormodel)
212	78x	param_name2 <- paste0(param_name, param_suffix)
213
214	78x	de@priormodel <- h_jags_join_models(
215	78x	de@priormodel,
216	78x	priormodel
217		)
218	78x	ms <- setNames(list(param[1], param[2]), param_name2)
219	78x	de@init <- function(y) {
220	21x	c(init(y), setNames(list(mean(param)), param_name))
221		}
222	78x	de@sample <- c(de@sample, param_name)
223		}
224	157x	de@modelspecs <- function(from_prior) {
225	60x	c(modelspecs(from_prior), ms)
226		}
227	157x	de@use_fixed <- c(de@use_fixed, use_fixed)
228	157x	de
229		}
230
231		#' Convert an ordinal CRM model to the Equivalent Binary CRM Model for a Specific
232		#' Grade
233		#'
234		#' @description `r lifecycle::badge("experimental")`
235		#'
236		#' A simple helper function that takes a [`LogisticLogNormalOrdinal`] and an
237		#' integer grade and converts them to the equivalent `LogisticLogNormal` model.
238		#'
239		#' @param x (`LogisticLogNormalOrdinal`)\cr the `LogisticLogNormalOrdinal`
240		#' model to covert
241		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent model
242		#' is required.
243		#' @return A [`LogisticLogNormal`] model.
244		#'
245		#' @export
246		h_convert_ordinal_model <- function(x, grade) {
247		# Validate
248	!	assert_integer(grade, len = 1, lower = 1)
249	!	assert_class(x, "LogisticLogNormalOrdinal")
250		# Execute
251	!	LogisticLogNormal(
252	!	mean = x@params@mean[-grade],
253	!	cov = x@params@cov[-grade, -grade],
254	!	ref_dose = x@ref_dose
255		)
256		}

1		#' @include helpers.R
2		#' @include ModelParams-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# ModelParamsNormal ----
7
8		## class ----
9
10		#' `ModelParamsNormal`
11		#'
12		#' @description `r lifecycle::badge("experimental")`
13		#'
14		#' [`ModelParamsNormal`] is the class for a bivariate normal model parameters,
15		#' i.e. the mean vector, covariance matrix and precision matrix.
16		#' The precision matrix is an inverse of the covariance matrix in the
17		#' `JAGS` and it is computed internally by the object constructor function.
18		#'
19		#' @slot mean (`numeric`)\cr the mean vector.
20		#' @slot cov (`matrix`)\cr the covariance matrix.
21		#' @slot prec (`matrix`)\cr the precision matrix, which is an inverse matrix of the `cov`.
22		#'
23		#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`].
24		#'
25		#' @aliases ModelParamsNormal
26		#' @export
27		#'
28		.ModelParamsNormal <- setClass(
29		Class = "ModelParamsNormal",
30		slots = c(
31		mean = "numeric",
32		cov = "matrix",
33		prec = "matrix"
34		),
35		contains = "CrmPackClass",
36		validity = v_model_params_normal
37		)
38
39		## constructor ----
40
41		#' @rdname ModelParamsNormal-class
42		#'
43		#' @param mean (`numeric`)\cr the prior mean vector.
44		#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
45		#' `prec` is internally calculated as an inverse of `cov`.
46		#'
47		#' @export
48		#' @examples
49		#' ModelParamsNormal(mean = c(1, 6), cov = diag(2))
50		ModelParamsNormal <- function(mean, cov) {
51	504x	assert_matrix(
52	504x	cov,
53	504x	mode = "numeric",
54	504x	any.missing = FALSE,
55	504x	nrows = length(mean),
56	504x	ncols = length(mean)
57		)
58		# To ensure that `cov` is invertible:
59	504x	assert_true(h_is_positive_definite(cov, length(mean)))
60
61	504x	.ModelParamsNormal(
62	504x	mean = mean,
63	504x	cov = cov,
64	504x	prec = solve(cov)
65		)
66		}
67
68		## default constructor ----
69
70		#' @rdname ModelParamsNormal-class
71		#' @note Typically, end users will not use the `.ModelPAramsNormal()` function.
72		#' @export
73		.DefaultModelParamsNormal <- function() {
74	3x	ModelParamsNormal(
75	3x	mean = c(1, 0),
76	3x	cov = matrix(c(1, 0, 0, 1), nrow = 2)
77		)
78		}

1		# These functions will need to be amended to support the report_label slot if
2		# and when it is added to NextBest classes
3
4		# NextBestMTD ----
5
6		#' @description `r lifecycle::badge("experimental")`
7		#' @inheritParams knit_print.StoppingTargetProb
8		#' @param target_label (`character`)\cr the term used to describe the target
9		#' toxicity rate
10		#' @rdname knit_print
11		#' @export
12		#' @method knit_print NextBestMTD
13		knit_print.NextBestMTD <- function(
14		x,
15		...,
16		target_label = "the 25th centile",
17		tox_label = "toxicity",
18		asis = TRUE
19		) {
20		# Validate
21	6x	assert_flag(asis)
22	6x	assert_character(target_label, len = 1, any.missing = FALSE)
23
24	6x	tox_label <- h_prepare_labels(tox_label)
25		# Execute
26	6x	rv <- paste0(
27	6x	"The dose level recommended for the next cohort will be selected as follows:\n\n",
28	6x	"- First, ",
29	6x	target_label,
30	6x	" of the posterior distribution of ",
31	6x	tox_label[1],
32	6x	" will be calculated for all dose levels that are eligible according to the ",
33	6x	" Increments rule.\n",
34	6x	"- Next, the \"target dose\" (which may not be part of the dose grid) for which ",
35	6x	target_label,
36	6x	" of the posterior distribution of ",
37	6x	tox_label[1],
38	6x	" is exactly equal to the target rate of ",
39	6x	x@target,
40	6x	" will be determined.\n",
41	6x	"- Finally, the dose level whose absolute distance from the target dose ",
42	6x	"is smallest will be selected as the recommended dose for the next cohort\n\n"
43		)
44
45	6x	if (asis) {
46	!	rv <- knitr::asis_output(rv)
47		}
48	6x	rv
49		}
50
51		# NextBestNCRM ----
52
53		#' @description `r lifecycle::badge("experimental")`
54		#' @inheritParams knit_print.StoppingTargetProb
55		#' @rdname knit_print
56		#' @export
57		#' @method knit_print NextBestNCRM
58		knit_print.NextBestNCRM <- function(
59		x,
60		...,
61		tox_label = "toxicity",
62		asis = TRUE
63		) {
64		# Validate
65	6x	assert_flag(asis)
66	6x	assert_character(tox_label, max.len = 2, any.missing = FALSE)
67
68		# Execute
69	6x	rv <- paste0(
70	6x	"The dose recommended for the next cohort will be chosen in the following ",
71	6x	"way. First, doses that are ineligible according to the increments rule ",
72	6x	"will be discarded. Next, any dose for which the mean posterior probability of ",
73	6x	tox_label,
74	6x	" being in the overdose range - (",
75	6x	x@overdose[1],
76		", ",
77	6x	x@overdose[2],
78	6x	"] - is ",
79	6x	x@max_overdose_prob,
80	6x	" or more will also be discarded. Finally, the dose amongst those remaining ",
81	6x	"which has the highest chance that the mean posterior probability of ",
82	6x	tox_label,
83	6x	" is in the target ",
84	6x	tox_label,
85	6x	" range of ",
86	6x	x@target[1],
87	6x	" to ",
88	6x	x@target[2],
89	6x	" (inclusive) will be selected.\n\n"
90		)
91
92	6x	if (asis) {
93	!	rv <- knitr::asis_output(rv)
94		}
95	6x	rv
96		}
97
98		# NextBestThreePlusThree ----
99
100		#' @description `r lifecycle::badge("experimental")`
101		#' @param label (`character`)\cr The term used to label the participants.
102		#' @param tox_label (`character`)\cr the term used to describe toxicity. See
103		#' Usage Notes below.
104		#' See Usage Notes below.
105		#' @section Usage Notes:
106		#' This section describes the use of `label` and `tox_label`, collectively
107		#' referred to as `label`s.
108		#' A `label` should be a scalar or a vector of length 2. If a scalar, it is
109		#' converted by adding a second element that is equal to the first, suffixed by `s`.
110		#' For example, `tox_label = "DLT"` becomes `tox_label = c("DLT", "DLTs")`. The
111		#' first element of the vector is used to describe a count of 1. The second
112		#' is used in all other cases.
113		#' @rdname knit_print
114		#' @export
115		#' @method knit_print NextBestThreePlusThree
116		knit_print.NextBestThreePlusThree <- function(
117		x,
118		...,
119		tox_label = c("toxicity", "toxicities"),
120		label = "participant",
121		asis = TRUE
122		) {
123		# Validate
124	4x	assert_flag(asis)
125
126		# Prepare
127	4x	tox_label <- h_prepare_labels(tox_label)
128	4x	label <- h_prepare_labels(label)
129
130		# Execute
131	4x	rv <- paste0(
132	4x	"The dose recommended for the next cohort will be chosen using the \"Three ",
133	4x	"Plus Three\" rule.\n\n- If no ",
134	4x	tox_label[2],
135	4x	" have been reported at the current dose level, escalate by one dose level.\n",
136	4x	"- If the observed ",
137	4x	tox_label[1],
138	4x	" rate at the current dose level is exactly 1/3 and no more than three ",
139	4x	label[2],
140	4x	" treated at the current dose level are evaluable, remain at the current ",
141	4x	"dose level.\n",
142	4x	"- Otherwise, recommend that the trial stops and identify the MTD as dose ",
143	4x	"level immediately below the current one.\n\n"
144		)
145
146	4x	if (asis) {
147	!	rv <- knitr::asis_output(rv)
148		}
149	4x	rv
150		}
151
152		# NextBestDualEndpoint ----
153
154		#' @description `r lifecycle::badge("experimental")`
155		#' @inheritParams knit_print.StoppingTargetProb
156		#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
157		#' @param biomarker_units (`character`)\cr the units in which the biomarker is
158		#' measured
159		#' @rdname knit_print
160		#' @export
161		#' @method knit_print NextBestDualEndpoint
162		knit_print.NextBestDualEndpoint <- function(
163		x,
164		...,
165		tox_label = "toxicity",
166		biomarker_label = "the biomarker",
167		biomarker_units = ifelse(x@target_relative, "%", ""),
168		asis = TRUE
169		) {
170	4x	assert_flag(asis)
171	4x	assert_character(tox_label, len = 1, any.missing = FALSE)
172	4x	assert_character(biomarker_label, len = 1, any.missing = FALSE)
173	4x	assert_character(biomarker_units, len = 1, any.missing = FALSE)
174
175	4x	rv <- paste0(
176	4x	"The dose recommended for the next cohort will be chosen in the following ",
177	4x	"way. First, doses that are ineligible according to the increments rule ",
178	4x	"will be discarded. Next, any dose for which the mean posterior probability of ",
179	4x	tox_label,
180	4x	" being in the overdose range - (",
181	4x	x@overdose[1],
182		", ",
183	4x	x@overdose[2],
184	4x	"] - is ",
185	4x	x@max_overdose_prob,
186	4x	" or more will also be discarded. Finally, the dose amongst those remaining ",
187	4x	"which has the highest chance that the mean posterior probability that ",
188	4x	biomarker_label,
189	4x	" is in the target range for ",
190	4x	biomarker_label,
191	4x	", which is ",
192	4x	x@target[1],
193	4x	ifelse(
194	4x	x@target_relative,
195		"",
196	4x	stringr::str_squish(paste0(" ", biomarker_units))
197		),
198	4x	" to ",
199	4x	x@target[2],
200	4x	ifelse(
201	4x	x@target_relative,
202		"",
203	4x	stringr::str_squish(paste0(" ", biomarker_units))
204		),
205	4x	" (inclusive),",
206	4x	ifelse(
207	4x	x@target_relative,
208	4x	paste0(" of the maximum ", biomarker_label, " value"),
209		""
210		),
211	4x	" will be selected, provided that this probability exceeds ",
212	4x	x@target_thresh,
213	4x	". If no dose meets this threshold, then the highest eligible dose will ",
214	4x	"be selected.\n\n"
215		)
216
217	4x	if (asis) {
218	!	rv <- knitr::asis_output(rv)
219		}
220	4x	rv
221		}
222
223		# NextBestMinDist ----
224
225		#' @description `r lifecycle::badge("experimental")`
226		#' @inheritParams knit_print.StoppingTargetProb
227		#' @rdname knit_print
228		#' @export
229		#' @method knit_print NextBestMinDist
230		knit_print.NextBestMinDist <- function(
231		x,
232		...,
233		tox_label = "toxicity",
234		asis = TRUE
235		) {
236		# Validate
237	2x	assert_flag(asis)
238	2x	assert_character(tox_label, len = 1, any.missing = FALSE)
239
240		# Execute
241	2x	rv <- paste0(
242	2x	"The dose recommended for the next cohort will be the one which is both ",
243	2x	"eligible and which has the smallest absolute difference between ",
244	2x	"its mean posterior estimate of the probability of ",
245	2x	tox_label,
246	2x	" and the target ",
247	2x	tox_label,
248	2x	" rate [",
249	2x	x@target,
250	2x	"].\n\n"
251		)
252
253	2x	if (asis) {
254	!	rv <- knitr::asis_output(rv)
255		}
256	2x	rv
257		}
258
259		# NextBestInfTheory ----
260
261		#' @description `r lifecycle::badge("experimental")`
262		#' @inheritParams knit_print.StoppingTargetProb
263		#' @param citation_text (`character`)\cr the text used to cite Mozgunov & Jaki
264		#' @param citation_link (`character`)\cr the link to Mozgunov & Jaki
265		#' @section Usage Notes:
266		#' To use a BibTeX-style citation, specify (for example) `citation_text =
267		#' "@MOZGUNOV", citation_link = ""`.
268		#' @rdname knit_print
269		#' @export
270		#' @method knit_print NextBestInfTheory
271		knit_print.NextBestInfTheory <- function(
272		x,
273		...,
274		tox_label = "toxicity",
275		citation_text = "Mozgunov & Jaki (2019)",
276		citation_link = "https://doi.org/10.1002/sim.8450",
277		asis = TRUE
278		) {
279		# Validate
280	2x	assert_flag(asis)
281	2x	assert_character(tox_label, len = 1, any.missing = FALSE)
282	2x	assert_character(citation_text, len = 1, any.missing = FALSE)
283	2x	assert_character(citation_link, len = 1, any.missing = FALSE)
284
285		# Execute
286	2x	rv <- paste0(
287	2x	"The recommended dose for the next cohort will be chosen using the ",
288	2x	"complex infinite bounds penalisation (CIBP) criterion of ",
289		"[",
290	2x	citation_text,
291		"]",
292	2x	ifelse(nchar(citation_link) > 0, paste0("(", citation_link, ")"), ""),
293	2x	". Let\n\n",
294	2x	"$$ \\delta(\\hat{p}_d, \\gamma) = \\frac{(\\hat{p}_d - \\gamma)^2}",
295	2x	"{\\hat{p}_d^a \\cdot (1 - \\hat{p}_d)^{2 - a}} $$\n\n",
296	2x	"where a is the non-centrality parameter with a value of ",
297	2x	x@asymmetry,
298	2x	", γ is the target ",
299	2x	tox_label,
300	2x	" rate with a value of ",
301	2x	x@target,
302	2x	" and $\\hat{p}_d$ is the mean posterior estimate of the probability of ",
303	2x	tox_label,
304	2x	" at dose level d.\n\n",
305	2x	"The recommended dose for the next cohort will be ",
306	2x	"the value of d that minimises $\\delta(\\hat{p}_d, \\gamma)$.\n\n"
307		)
308
309	2x	if (asis) {
310	!	rv <- knitr::asis_output(rv)
311		}
312	2x	rv
313		}
314
315		# NextBestTD ----
316
317		#' @description `r lifecycle::badge("experimental")`
318		#' @inheritParams knit_print.StoppingTargetProb
319		#' @rdname knit_print
320		#' @export
321		#' @method knit_print NextBestTD
322		knit_print.NextBestTD <- function(
323		x,
324		...,
325		tox_label = "toxicity",
326		asis = TRUE
327		) {
328		# Validate
329	4x	assert_flag(asis)
330	4x	assert_character(tox_label, len = 1, any.missing = FALSE)
331
332		# Execute
333	4x	rv <- paste0(
334	4x	"The dose recommended for the next cohort will be the one which is both ",
335	4x	"eligible and which is the highest dose in the dose grid strictly less than ",
336	4x	"the dose (which may not be in the dose grid) that has a posterior plug-in ",
337	4x	"estimate of the probability of ",
338	4x	tox_label,
339	4x	" exactly equal to the target ",
340	4x	tox_label,
341	4x	" rate, either during [",
342	4x	x@prob_target_drt,
343	4x	"] or at the end of the trial [",
344	4x	x@prob_target_eot,
345	4x	"].\n\n"
346		)
347
348	4x	if (asis) {
349	!	rv <- knitr::asis_output(rv)
350		}
351	4x	rv
352		}
353
354		# NextBestMaxGain ----
355
356		#' @description `r lifecycle::badge("experimental")`
357		#' @inheritParams knit_print.StoppingTargetProb
358		#' @rdname knit_print
359		#' @export
360		#' @method knit_print NextBestMaxGain
361		knit_print.NextBestMaxGain <- function(
362		x,
363		...,
364		tox_label = "toxicity",
365		asis = TRUE
366		) {
367		# Validate
368	4x	assert_flag(asis)
369	4x	assert_character(tox_label, len = 1, any.missing = FALSE)
370
371		# Execute
372	4x	rv <- paste0(
373	4x	"The dose recommended for the next cohort will be the one which is closest to ",
374	4x	"Gstar, the dose that maximises the gain for probability of ",
375	4x	tox_label,
376	4x	" exactly equal to the target ",
377	4x	tox_label,
378	4x	" rate, either during [",
379	4x	x@prob_target_drt,
380	4x	"] or at the end of the trial [",
381	4x	x@prob_target_eot,
382	4x	"].\n\n"
383		)
384
385	4x	if (asis) {
386	!	rv <- knitr::asis_output(rv)
387		}
388	4x	rv
389		}
390
391		# NextBestProbMTDLTE ----
392
393		#' @description `r lifecycle::badge("experimental")`
394		#' @inheritParams knit_print.StoppingTargetProb
395		#' @rdname knit_print
396		#' @export
397		#' @method knit_print NextBestProbMTDLTE
398		knit_print.NextBestProbMTDLTE <- function(
399		x,
400		...,
401		tox_label = "toxicity",
402		asis = TRUE
403		) {
404		# Validate
405	2x	assert_flag(asis)
406	2x	assert_character(tox_label, len = 1, any.missing = FALSE)
407
408		# Execute
409	2x	rv <- paste0(
410	2x	"The dose recommended for the next cohort will be the dose level with ",
411	2x	"the highest probability of being the highest dose with an estimated ",
412	2x	"probability of ",
413	2x	tox_label,
414	2x	" less than or equal to ",
415	2x	x@target,
416	2x	".\n\n"
417		)
418
419	2x	if (asis) {
420	!	rv <- knitr::asis_output(rv)
421		}
422	2x	rv
423		}
424
425		# NextBestProbMTDMinDist ----
426
427		#' @description `r lifecycle::badge("experimental")`
428		#' @inheritParams knit_print.StoppingTargetProb
429		#' @rdname knit_print
430		#' @export
431		#' @method knit_print NextBestProbMTDMinDist
432		knit_print.NextBestProbMTDMinDist <- function(
433		x,
434		...,
435		tox_label = "toxicity",
436		asis = TRUE
437		) {
438		# Validate
439	2x	assert_flag(asis)
440	2x	assert_character(tox_label, len = 1, any.missing = FALSE)
441
442		# Execute
443	2x	rv <- paste0(
444	2x	"The dose recommended for the next cohort will be the dose level with ",
445	2x	"the highest probability of being the highest dose with an estimated ",
446	2x	"probability of ",
447	2x	tox_label,
448	2x	" closest to ",
449	2x	x@target,
450	2x	".\n\n"
451		)
452
453	2x	if (asis) {
454	!	rv <- knitr::asis_output(rv)
455		}
456	2x	rv
457		}
458
459		# NextBestNCRMLoss ----
460
461		#' @description `r lifecycle::badge("experimental")`
462		#' @inheritParams knit_print.StoppingTargetProb
463		#' @param format_func (`function`)\cr The function used to format the range table.
464		#' @importFrom rlang .data
465		#' @rdname knit_print
466		#' @export
467		#' @method knit_print NextBestNCRMLoss
468		knit_print.NextBestNCRMLoss <- function(
469		x,
470		...,
471		tox_label = "toxicity",
472		asis = TRUE,
473		format_func = h_knit_format_func
474		) {
475		# Validate
476	2x	assert_flag(asis)
477	2x	assert_character(tox_label, len = 1, any.missing = FALSE)
478
479		# Execute
480	2x	param <- list(...)
481	2x	param[["x"]] <- x %>%
482	2x	tidy() %>%
483	2x	dplyr::select(-MaxOverdoseProb)
484	2x	param[["col.names"]] <- c("Range", "Lower", "Upper", "Loss Coefficient")
485	2x	rv <- paste0(
486	2x	"The dose recommended for the next cohort will be chosen in the following ",
487	2x	"way:\n\n- First, the chance that the probability of ",
488	2x	tox_label,
489	2x	" falls into each of the underdose, target ",
490	2x	ifelse(
491	2x	any(x@unacceptable != c(1, 1)),
492	2x	", overdose and unacceptable",
493	2x	" and overdose"
494		),
495	2x	" dose ranges is calculated for element of the dose grid.\n",
496	2x	"- Next, the loss associated with each dose is calculated by multiplying ",
497	2x	"these probabilities by the corresponding loss coefficient and summing the result.\n",
498	2x	"- Then ineligible doses, and those with a probability of being in the ",
499	2x	ifelse(
500	2x	length(x@losses) == 3,
501	2x	"overdose range",
502	2x	"overdose or unaccaptable ranges"
503		),
504	2x	" that is greater than ",
505	2x	x@max_overdose_prob,
506	2x	", are discarded.\n",
507	2x	"- Finally, the dose level with the smallest loss is selected as the ",
508	2x	"recommended dose for the next cohort.\n\n",
509	2x	ifelse(
510	2x	toupper(tox_label) == tox_label,
511	2x	tox_label,
512	2x	stringr::str_to_sentence(tox_label)
513		),
514	2x	" ranges and loss coefficients are given in the following table:\n\n",
515	2x	paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n"),
516	2x	"\n\n"
517		)
518
519	2x	if (asis) {
520	!	rv <- knitr::asis_output(rv)
521		}
522	2x	rv
523		}
524
525		# NextBestTDsamples ----
526
527		#' @description `r lifecycle::badge("experimental")`
528		#' @inheritParams knit_print.StoppingTargetProb
529		#' @rdname knit_print
530		#' @export
531		#' @method knit_print NextBestTDsamples
532		knit_print.NextBestTDsamples <- function(
533		x,
534		...,
535		tox_label = "toxicity",
536		asis = TRUE
537		) {
538		# Validate
539	2x	assert_flag(asis)
540	2x	assert_character(tox_label, len = 1, any.missing = FALSE)
541
542		# Execute
543	2x	rv <- paste0(
544	2x	"The dose recommended for the next cohort will be the one which is both ",
545	2x	"eligible and which is the highest dose in the dose grid strictly less than ",
546	2x	"the dose (which may not be in the dose grid) that has a full Bayes posterior ",
547	2x	"estimate of the probability of ",
548	2x	tox_label,
549	2x	" exactly equal to the target ",
550	2x	tox_label,
551	2x	" rate, either during [",
552	2x	x@prob_target_drt,
553	2x	"] or at the end of the trial [",
554	2x	x@prob_target_eot,
555	2x	"].\n\n"
556		)
557
558	2x	if (asis) {
559	!	rv <- knitr::asis_output(rv)
560		}
561	2x	rv
562		}
563
564
565		# NextBestMaxGainSamples ----
566
567		#' @description `r lifecycle::badge("experimental")`
568		#' @inheritParams knit_print.StoppingTargetProb
569		#' @rdname knit_print
570		#' @export
571		#' @method knit_print NextBestMaxGainSamples
572		knit_print.NextBestMaxGainSamples <- function(
573		x,
574		...,
575		tox_label = "toxicity",
576		asis = TRUE
577		) {
578		# Validate
579	4x	assert_flag(asis)
580	4x	assert_character(tox_label, len = 1, any.missing = FALSE)
581
582		# Execute
583	4x	rv <- paste0(
584	4x	"The dose recommended for the next cohort will be the one which is closest to ",
585	4x	"Gstar, the dose for which the full Bayes posterior estimate of the probability of ",
586	4x	tox_label,
587	4x	" maximises the gain relative to the target ",
588	4x	tox_label,
589	4x	" rate, either during [",
590	4x	x@prob_target_drt,
591	4x	"] or at the end of the trial [",
592	4x	x@prob_target_eot,
593	4x	"].\n\n"
594		)
595
596	4x	if (asis) {
597	!	rv <- knitr::asis_output(rv)
598		}
599	4x	rv
600		}
601
602		# NextBestOrdinal ----
603
604		#' @description `r lifecycle::badge("experimental")`
605		#' @inheritParams knit_print.StoppingTargetProb
606		#' @rdname knit_print
607		#' @export
608		#' @method knit_print NextBestOrdinal
609		knit_print.NextBestOrdinal <- function(
610		x,
611		...,
612		tox_label = "toxicity",
613		asis = TRUE
614		) {
615	4x	assert_flag(asis)
616	4x	assert_character(tox_label, max.len = 2, any.missing = FALSE)
617
618	4x	tox_label <- h_prepare_labels(tox_label)
619	4x	rv <- paste0(
620	4x	"Based on a ",
621	4x	tox_label[1],
622	4x	" grade of ",
623	4x	x@grade,
624		": ",
625	4x	paste0(
626	4x	knit_print(x@rule, asis = asis, tox_label = tox_label, ...),
627	4x	collapse = "\n"
628		),
629	4x	"\n\n"
630		)
631
632	4x	if (asis) {
633	!	rv <- knitr::asis_output(rv)
634		}
635	4x	rv
636		}

1		# Integration with knitr ----
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' We provide additional utility functions to allow human-friendly rendition of
6		#' crmPack objects in Markdown and Quarto files. This file contains methods for
7		#' all design classes, not just those that are direct descendants of `Design`.
8		#'
9		#' @return a character string that represents the object in markdown.
10		#' @name knit_print
11		NULL
12
13		#' Internal Helper Functions for Validation of [`StartingDose`] Objects
14		#'
15		#' @description `r lifecycle::badge("experimental")`
16		#'
17		#' Validates that the `StartingDose` object contains valid `starting_dose`.
18		#'
19		#' @param object (`StartingDose`)\cr object to validate.
20		#' @return A `character` vector with the validation failure messages,
21		#' or `TRUE` in case validation passes.
22		#' @keywords internal
23		v_starting_dose <- function(object) {
24	!	v <- Validate()
25	!	v$check(
26	!	test_number(object@starting_dose, finite = TRUE, lower = 0),
27	!	"starting_dose must be a non-negative, finite number"
28		)
29	!	v$result()
30		}
31
32		# Helper class
33
34		#' `StartingDose`
35		#'
36		#' @description `r lifecycle::badge("experimental")`
37		#'
38		#' [`StartingDose`] is a simple wrapper class for the `startingDose` slot of all
39		#' design classes. It is used internally by `knit_print` methods
40		#'
41		#' @slot starting_dose (`numeric`)\cr the starting dose
42		#' @rdname StartingDose-class
43		#' @keywords internal
44		.StartingDose <- setClass(
45		Class = "StartingDose",
46		slots = c(
47		starting_dose = "numeric"
48		),
49		prototype = prototype(
50		starting_dose = 1
51		),
52		validity = v_starting_dose,
53		contains = "CrmPackClass"
54		)
55
56		## constructor ----
57
58		#' @rdname StartingDose-class
59		#' @param starting_dose (`positive_number`)\cr see slot definition.
60		StartingDose <- function(starting_dose) {
61	24x	new(
62	24x	"StartingDose",
63	24x	starting_dose = starting_dose
64		)
65		}
66
67		#' @rdname StartingDose-class
68		#' @note Typically, end users will not use the `.DefaultStartingDose()` function.
69		.DefaultStartingDose <- function() {
70	3x	StartingDose(starting_dose = 5)
71		}
72
73		# Helper functions ----
74
75		h_knit_print_design <- function(
76		x,
77		...,
78		level = 2L,
79		title = "Design",
80		default_sections = NA,
81		user_sections = NA,
82		ignore_slots = c(),
83		asis = TRUE
84		) {
85	16x	assert_flag(asis)
86		# Because subsections use level + 1 and 6 is the lowest markdown header level
87	16x	assert_int(level, lower = 1, upper = 5)
88	16x	assert_character(title, any.missing = FALSE, len = 1L)
89
90	16x	slots_to_process <- setdiff(slotNames(x), ignore_slots)
91
92	16x	args <- list(...)
93	16x	units <- ifelse("units" %in% names(args), paste0(" ", args[["units"]]), "")
94	16x	section_labels <- h_prepare_section_labels(
95	16x	x,
96	16x	default_sections,
97	16x	user_sections
98		)
99	16x	assert_subset(slots_to_process, names(section_labels))
100
101	16x	rv <- paste0(
102	16x	h_markdown_header(title, level = level),
103	16x	paste0(
104	16x	lapply(
105	16x	slots_to_process,
106	16x	function(nm) {
107	118x	tmp <- switch(
108	118x	nm,
109	118x	starting_dose = knit_print(
110	118x	StartingDose(x@starting_dose),
111	118x	asis = FALSE,
112	118x	level = level + 1L,
113		...
114		),
115	118x	startingDose = knit_print(
116	118x	StartingDose(x@startingDose),
117	118x	asis = FALSE,
118	118x	level = level + 1L,
119		...
120		),
121	118x	pl_cohort_size = ifelse(
122	118x	identical(slot(x, "pl_cohort_size"), CohortSizeConst(0)),
123	118x	"Placebo will not be administered in the trial.\n\n",
124	118x	knit_print(
125	118x	slot(x, "pl_cohort_size"),
126	118x	asis = FALSE,
127	118x	level = level + 1L,
128		...
129		)
130		),
131		{
132	90x	knit_print(slot(x, nm), asis = FALSE, level = level + 1L, ...)
133		}
134		)
135	118x	paste0(h_markdown_header(section_labels[nm], level + 1L), tmp)
136		}
137		),
138	16x	collapse = "\n\n"
139		),
140	16x	"\n\n"
141		)
142
143	16x	if (asis) {
144	6x	rv <- knitr::asis_output(rv)
145		}
146	16x	rv
147		}
148
149		#' @description A Helper Function to create Markdown Headers
150		#'
151		#' @param text (`character`) the header text
152		#' @param level (`positive_integer`) the level of the header. Must be between 1 and 6.
153		#' @return the Markdown header string: a newline, `#` repeated `level` times,
154		#' a space, `text` followed by two newlines.
155		#' @keywords internal
156		#' @noRd
157		h_markdown_header <- function(text, level = 2L) {
158	142x	assert_character(text, any.missing = FALSE, len = 1L, min.chars = 2L)
159	139x	assert_int(level, lower = 1, upper = 6)
160
161	136x	paste0(
162	136x	"\n",
163	136x	stringr::str_dup("#", level),
164		" ",
165	136x	text,
166	136x	"\n\n"
167		)
168		}
169
170		#' Modify a Set of Default Slot Labels With Custom Custom Labels
171		#'
172		#' x (`S4`)\cr the S4 object for which slot labels are required
173		#' default_labels (`character`)\cr a vector of slot labels whose names are a
174		#' superset of the slot names of `x`
175		#' user_labels (`character`)\cr a vector of slot labels whose names are a
176		#' superset of the slot names of `x`. Can be `NA`, in which case no updates
177		#' are made
178		#' @returns `default_labels` updated according to `user_labels`
179		#' @noRd
180		#' @keywords internal
181		h_prepare_section_labels <- function(x, default_labels, user_labels = NA) {
182	22x	assert_true(isS4(x))
183	22x	assert_character(default_labels, any.missing = FALSE)
184
185	22x	if (!any(is.na(user_labels))) {
186	5x	assert_character(user_labels, any.missing = FALSE)
187	5x	assert_subset(names(user_labels), slotNames(x))
188
189	5x	for (nm in names(user_labels)) {
190	3x	default_labels[nm] <- user_labels[nm]
191		}
192		}
193	22x	default_labels
194		}
195
196		# Methods ----
197
198		# StartingDose ----
199
200		#' @description `r lifecycle::badge("experimental")`
201		#' @rdname knit_print
202		#' @export
203		#' @method knit_print StartingDose
204		knit_print.StartingDose <- function(x, ..., asis = TRUE) {
205	18x	assert_flag(asis)
206
207	18x	args <- list(...)
208	18x	units <- ifelse("units" %in% names(args), paste0(" ", args[["units"]]), "")
209	18x	rv <- paste0(
210	18x	"The starting dose is ",
211	18x	paste0(x@starting_dose, units),
212	18x	".\n\n"
213		)
214
215	18x	if (asis) {
216	!	rv <- knitr::asis_output(rv)
217		}
218	18x	rv
219		}
220
221		# RuleDesign ----
222
223		#' @description `r lifecycle::badge("experimental")`
224		#' @inheritParams knit_print.StoppingTargetProb
225		#' @param level (`positive_integer`) The level of the headings used to separate
226		#' slots. Must be between 1 and 6.
227		#' @param title (`character`) The text of the heading of the section describing
228		#' the design
229		#' @param sections (`character`) a named vector of length at least 4 defining
230		#' the headings used to define the sections corresponding to the design's slots.
231		#' The element names must match the Design's slot names.
232		#' @rdname knit_print
233		#' @export
234		#' @method knit_print RuleDesign
235		knit_print.RuleDesign <- function(
236		x,
237		...,
238		level = 2L,
239		title = "Design",
240		sections = NA,
241		asis = TRUE
242		) {
243	2x	h_knit_print_design(
244	2x	x,
245		...,
246	2x	level = 2L,
247	2x	title = "Design",
248	2x	default_sections = c(
249	2x	"nextBest" = "Dose recommendation",
250	2x	"cohort_size" = "Cohort size",
251	2x	"data" = "Observed data",
252	2x	"startingDose" = "Starting dose"
253		),
254	2x	user_sections = sections,
255	2x	asis = asis
256		)
257		}
258
259		# Design ----
260
261		#' @description `r lifecycle::badge("experimental")`
262		#' @inheritParams knit_print.RuleDesign
263		#' @rdname knit_print
264		#' @export
265		#' @method knit_print Design
266		knit_print.Design <- function(
267		x,
268		...,
269		level = 2L,
270		title = "Design",
271		sections = NA,
272		asis = TRUE
273		) {
274	6x	h_knit_print_design(
275	6x	x,
276		...,
277	6x	level = 2L,
278	6x	title = "Design",
279	6x	default_sections = c(
280	6x	"nextBest" = "Dose recommendation",
281	6x	"cohort_size" = "Cohort size",
282	6x	"data" = "Observed data",
283	6x	"startingDose" = "Starting dose",
284	6x	"increments" = "Escalation rule",
285	6x	"stopping" = "Stopping rule",
286	6x	"model" = "Dose toxicity model",
287	6x	"pl_cohort_size" = "Use of placebo"
288		),
289	6x	user_sections = sections,
290	6x	asis = asis
291		)
292		}
293
294		# DualDesign ----
295
296		#' @description `r lifecycle::badge("experimental")`
297		#' @inheritParams knit_print.RuleDesign
298		#' @rdname knit_print
299		#' @export
300		#' @method knit_print DualDesign
301		knit_print.DualDesign <- function(
302		x,
303		...,
304		level = 2L,
305		title = "Design",
306		sections = NA,
307		asis = TRUE
308		) {
309	2x	assert_flag(asis)
310	2x	assert_character(title, len = 1, any.missing = FALSE)
311	2x	assert_integer(level, len = 1, lower = 1, upper = 6)
312
313	2x	args <- list(...)
314	2x	bLabel <- ifelse(
315	2x	"biomarker_label" %in% names(args),
316	2x	args[["biomarker_label"]],
317	2x	"biomarker"
318		)
319	2x	tLabel <- ifelse(
320	2x	"tox_label" %in% names(args),
321	2x	args[["tox_label"]],
322	2x	"toxicity"
323		)
324
325	2x	if (is.na(sections)) {
326	2x	sections <- c(
327	2x	"model" = paste0("Dose-", tLabel, " and dose-", bLabel, " models")
328		)
329		} else {
330	!	if (!("model" %in% names(sections))) {
331	!	sections["model"] <- paste0(
332	!	"Dose-",
333	!	tLabel,
334	!	" and dose-",
335	!	bLabel,
336	!	" models"
337		)
338		}
339		}
340
341	2x	knit_print.Design(
342	2x	x,
343	2x	level = level,
344	2x	title = title,
345	2x	sections = sections,
346	2x	asis = asis,
347		...
348		)
349		}
350
351		# DADesign ----
352
353		#' @description `r lifecycle::badge("experimental")`
354		#' @inheritParams knit_print.RuleDesign
355		#' @rdname knit_print
356		#' @export
357		#' @method knit_print DADesign
358		knit_print.DADesign <- function(
359		x,
360		...,
361		level = 2L,
362		title = "Design",
363		sections = NA,
364		asis = TRUE
365		) {
366	2x	h_knit_print_design(
367	2x	x,
368		...,
369	2x	level = 2L,
370	2x	title = "Design",
371	2x	default_sections = c(
372	2x	"nextBest" = "Dose recommendation",
373	2x	"cohort_size" = "Cohort size",
374	2x	"data" = "Observed data",
375	2x	"startingDose" = "Starting dose",
376	2x	"increments" = "Escalation rule",
377	2x	"stopping" = "Stopping rule",
378	2x	"model" = "Dose toxicity model",
379	2x	"pl_cohort_size" = "Use of placebo",
380	2x	"safetyWindow" = "Safety window"
381		),
382	2x	user_sections = sections,
383	2x	asis = asis
384		)
385		}
386
387		# TDDesign ----
388
389		#' @description `r lifecycle::badge("experimental")`
390		#' @inheritParams knit_print.RuleDesign
391		#' @rdname knit_print
392		#' @export
393		#' @method knit_print TDDesign
394		knit_print.TDDesign <- function(
395		x,
396		...,
397		level = 2L,
398		title = "Design",
399		sections = NA,
400		asis = TRUE
401		) {
402	2x	knit_print.Design(
403	2x	x,
404	2x	level = level,
405	2x	title = title,
406	2x	sections = sections,
407	2x	asis = asis,
408		...
409		)
410		}
411
412		# DualResponsesDesign ----
413
414		#' @description `r lifecycle::badge("experimental")`
415		#' @inheritParams knit_print.RuleDesign
416		#' @rdname knit_print
417		#' @export
418		#' @method knit_print DualResponsesDesign
419		knit_print.DualResponsesDesign <- function(
420		x,
421		...,
422		level = 2L,
423		title = "Design",
424		sections = NA,
425		asis = TRUE
426		) {
427		knit_print.Design(
428		x,
429		level = level,
430		title = title,
431		sections = sections,
432		asis = asis,
433		...
434		)
435		}
436
437		# DesignOrdinal ----
438
439		#' @description `r lifecycle::badge("experimental")`
440		#' @inheritParams knit_print.RuleDesign
441		#' @rdname knit_print
442		#' @export
443		#' @method knit_print DesignOrdinal
444		knit_print.DesignOrdinal <- function(
445		x,
446		...,
447		level = 2L,
448		title = "Design",
449		sections = NA,
450		asis = TRUE
451		) {
452	!	h_knit_print_design(
453	!	x,
454		...,
455	!	level = 2L,
456	!	title = "Design",
457	!	default_sections = c(
458	!	"next_best" = "Dose recommendation",
459	!	"cohort_size" = "Cohort size",
460	!	"data" = "Observed data",
461	!	"starting_dose" = "Starting dose",
462	!	"increments" = "Escalation rule",
463	!	"stopping" = "Stopping rule",
464	!	"model" = "Dose toxicity model",
465	!	"pl_cohort_size" = "Use of placebo"
466		),
467	!	user_sections = sections,
468	!	asis = asis
469		)
470		}
471
472		# DesignGrouped ----
473
474		# Needs special handling because of the empty models and nested rules in the
475		# mono and combo slots and because of the many slots that are of built-in types
476		# rather than being of crmPack-specific types
477
478		#' @description `r lifecycle::badge("experimental")`
479		#' @inheritParams knit_print.RuleDesign
480		#' @rdname knit_print
481		#' @export
482		#' @method knit_print DesignGrouped
483		knit_print.DesignGrouped <- function(
484		x,
485		...,
486		level = 2L,
487		title = "Design",
488		sections = c(
489		"model" = "Dose toxicity model",
490		"mono" = "Monotherapy rules",
491		"combo" = "Combination therapy rules",
492		"other" = "Other details"
493		),
494		asis = TRUE
495		) {
496	!	assert_flag(asis)
497	!	assert_character(title, len = 1, any.missing = FALSE)
498	!	assert_integer(level, len = 1, lower = 1, upper = 6)
499
500	!	rv <- paste0(
501	!	h_markdown_header(sections["model"], level = level),
502	!	knit_print(x@model, asis = FALSE, ...),
503	!	h_markdown_header(sections["mono"], level = level),
504	!	h_knit_print_design(
505	!	x@mono,
506	!	asis = FALSE,
507	!	level = level + 1L,
508	!	ignore_slots = c("model"),
509	!	default_sections = c(
510	!	"nextBest" = "Dose recommendation",
511	!	"cohort_size" = "Cohort size",
512	!	"data" = "Observed monotherapy data",
513	!	"startingDose" = "Starting dose",
514	!	"increments" = "Escalation rule",
515	!	"stopping" = "Stopping rule",
516	!	"pl_cohort_size" = "Use of placebo"
517		),
518	!	sections = sections[["mono"]],
519		...
520		),
521	!	h_markdown_header(sections["combo"], level = level),
522	!	h_knit_print_design(
523	!	x@combo,
524	!	asis = FALSE,
525	!	level = level + 1L,
526	!	ignore_slots = "model",
527	!	default_sections = c(
528	!	"nextBest" = "Dose recommendation",
529	!	"cohort_size" = "Cohort size",
530	!	"data" = "Observed combination therapy data",
531	!	"startingDose" = "Starting dose",
532	!	"increments" = "Escalation rule",
533	!	"stopping" = "Stopping rule",
534	!	"pl_cohort_size" = "Use of placebo"
535		),
536	!	sections = sections[["combo"]],
537		...
538		),
539	!	h_markdown_header(sections["other"], level = level),
540	!	ifelse(
541	!	x@first_cohort_mono_only,
542	!	paste0(
543	!	"No combination dosing may occur until the results of at least one ",
544	!	"monotherapy cohort are available.\n\n"
545		),
546	!	"Simultaneous combination and monotherapy dosing is permitted from the outset.\n\n"
547		),
548	!	ifelse(
549	!	x@same_dose_for_start,
550	!	paste0(
551	!	"When monotherapy and combination therapy are used in the same cohort ",
552	!	"for the first time, the same dose must be used for both regimens.\n\n"
553		),
554	!	paste0(
555	!	"When monotherapy and combination therapy are used in the same cohort ",
556	!	"for the first time, the use of a different dose in each regimen is permitted.\n\n"
557		)
558		),
559	!	ifelse(
560	!	x@same_dose_for_all,
561	!	paste0(
562	!	"Whenever monotherapy and combination therapy are used in the same cohort, ",
563	!	"the same dose must be used for both regimens.\n\n"
564		),
565	!	paste0(
566	!	"Whenever monotherapy and combination therapy are used in the same cohort, ",
567	!	"the use of a different dose in each regimen is permitted.\n\n"
568		)
569		)
570		)
571
572	!	if (asis) {
573	!	rv <- knitr::asis_output(rv)
574		}
575	!	rv
576		}
577
578		# TDsamplesDesign ----
579
580		#' @description `r lifecycle::badge("experimental")`
581		#' @inheritParams knit_print.RuleDesign
582		#' @rdname knit_print
583		#' @export
584		#' @method knit_print TDsamplesDesign
585		knit_print.TDsamplesDesign <- function(
586		x,
587		...,
588		level = 2L,
589		title = "Design",
590		sections = NA,
591		asis = TRUE
592		) {
593	!	h_knit_print_design(
594	!	x,
595		...,
596	!	level = level,
597	!	title = title,
598	!	default_sections = c(
599	!	"nextBest" = "Dose recommendation",
600	!	"cohort_size" = "Cohort size",
601	!	"data" = "Observed data",
602	!	"startingDose" = "Starting dose",
603	!	"model" = "Dose toxicity model",
604	!	"stopping" = "Stopping rule",
605	!	"increments" = "Escalation rule",
606	!	"pl_cohort_size" = "Use of placebo"
607		),
608	!	user_sections = sections,
609	!	asis = asis
610		)
611		}
612
613		# DualResponsesDesign ----
614
615		#' @description `r lifecycle::badge("experimental")`
616		#' @inheritParams knit_print.RuleDesign
617		#' @rdname knit_print
618		#' @export
619		#' @method knit_print DualResponsesDesign
620		knit_print.DualResponsesDesign <- function(
621		x,
622		...,
623		level = 2L,
624		title = "Design",
625		sections = NA,
626		asis = TRUE
627		) {
628	2x	h_knit_print_design(
629	2x	x,
630		...,
631	2x	level = level,
632	2x	title = title,
633	2x	default_sections = c(
634	2x	"nextBest" = "Dose recommendation",
635	2x	"cohort_size" = "Cohort size",
636	2x	"data" = "Observed data",
637	2x	"startingDose" = "Starting dose",
638	2x	"increments" = "Escalation rule",
639	2x	"stopping" = "Stopping rule",
640	2x	"model" = "Dose-toxicity model",
641	2x	"eff_model" = "Dose-efficacy model",
642	2x	"pl_cohort_size" = "Use of placebo"
643		),
644	2x	ignore_sections = c("model", "eff_model"),
645	2x	sections = sections,
646	2x	asis = asis
647		)
648		}
649
650		# DualResponsesSamplesDesign ----
651
652		#' @description `r lifecycle::badge("experimental")`
653		#' @inheritParams knit_print.RuleDesign
654		#' @rdname knit_print
655		#' @export
656		#' @method knit_print DualResponsesSamplesDesign
657		knit_print.DualResponsesSamplesDesign <- function(
658		x,
659		...,
660		level = 2L,
661		title = "Design",
662		sections = NA,
663		asis = TRUE
664		) {
665	2x	h_knit_print_design(
666	2x	x,
667		...,
668	2x	level = level,
669	2x	title = title,
670	2x	default_sections = c(
671	2x	"nextBest" = "Dose recommendation",
672	2x	"cohort_size" = "Cohort size",
673	2x	"data" = "Observed data",
674	2x	"startingDose" = "Starting dose",
675	2x	"increments" = "Escalation rule",
676	2x	"stopping" = "Stopping rule",
677	2x	"model" = "Dose-toxicity model",
678	2x	"eff_model" = "Dose-efficacy model",
679	2x	"pl_cohort_size" = "Use of placebo"
680		),
681	2x	ignore_sections = c("model", "eff_model"),
682	2x	sections = sections,
683	2x	asis = asis
684		)
685		}
686
687		# RuleDesignOrdinal ----
688
689		#' @description `r lifecycle::badge("experimental")`
690		#' @inheritParams knit_print.RuleDesign
691		#' @rdname knit_print
692		#' @export
693		#' @method knit_print RuleDesignOrdinal
694		knit_print.RuleDesignOrdinal <- function(
695		x,
696		...,
697		level = 2L,
698		title = "Design",
699		sections = NA,
700		asis = TRUE
701		) {
702	2x	h_knit_print_design(
703	2x	x,
704		...,
705	2x	level = 2L,
706	2x	title = "Design",
707	2x	default_sections = c(
708	2x	"next_best" = "Dose recommendation",
709	2x	"cohort_size" = "Cohort size",
710	2x	"data" = "Observed data",
711	2x	"starting_dose" = "Starting dose"
712		),
713	2x	user_sections = sections,
714	2x	asis = asis
715		)
716		}

1		##' @include helpers.R
2		##' @include Model-class.R
3		NULL
4
5		# Helper functions ----
6
7		#' Get Starting Values for Quantiles Optimization
8		#'
9		#' @param parstart (`numeric` or `NULL`)\cr starting parameter values.
10		#' @param median (`numeric`)\cr median values.
11		#' @param dosegrid (`numeric`)\cr dose grid.
12		#' @param refDose (`number`)\cr reference dose.
13		#' @param logNormal (`flag`)\cr use log-normal prior?
14		#'
15		#' @return Numeric vector of starting values.
16		#' @keywords internal
17		h_get_quantiles_start_values <- function(
18		parstart,
19		median,
20		dosegrid,
21		refDose,
22		logNormal
23		) {
24	3x	if (is.null(parstart)) {
25		# Find approximate means for alpha and slope beta from fitting logistic model to medians.
26	2x	startAlphaBeta <- coef(lm(I(logit(median)) ~ I(log(dosegrid / refDose))))
27
28	2x	c(
29	2x	meanAlpha = unname(startAlphaBeta[1]),
30	2x	meanBeta = unname(
31	2x	if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2]
32		),
33	2x	sdAlpha = 1,
34	2x	sdBeta = 1,
35	2x	correlation = 0
36		)
37		} else {
38	1x	parstart
39		}
40		}
41
42		#' Target Function for Quantiles Optimization
43		#'
44		#' @param dosegrid (`numeric`)\cr dose grid.
45		#' @param refDose (`number`)\cr reference dose.
46		#' @param lower (`numeric`)\cr lower quantiles.
47		#' @param median (`numeric`)\cr median quantiles.
48		#' @param upper (`numeric`)\cr upper quantiles.
49		#' @param level (`number`)\cr credible level.
50		#' @param logNormal (`flag`)\cr use log-normal prior?
51		#' @param seed (`count`)\cr random seed.
52		#'
53		#' @return Function that computes target value for optimization.
54		#' @keywords internal
55		h_quantiles_target_function <- function(
56		dosegrid,
57		refDose,
58		lower,
59		median,
60		upper,
61		level,
62		logNormal,
63		seed
64		) {
65	1x	function(param) {
66		# Form the mean vector and covariance matrix
67	1x	mean <- param[1:2]
68	1x	cov <- matrix(
69	1x	c(
70	1x	param[3]^2,
71	1x	prod(param[3:5]),
72	1x	prod(param[3:5]),
73	1x	param[4]^2
74		),
75	1x	nrow = 2L,
76	1x	ncol = 2L
77		)
78
79		# Simulate from the corresponding normal distribution
80	1x	set.seed(seed)
81	1x	normalSamples <- mvtnorm::rmvnorm(
82	1x	n = 1e4L,
83	1x	mean = mean,
84	1x	sigma = cov
85		)
86
87		# Extract separate coefficients
88	1x	alphaSamples <- normalSamples[, 1L]
89	1x	betaSamples <- if (logNormal) {
90	!	exp(normalSamples[, 2L])
91		} else {
92	1x	normalSamples[, 2L]
93		}
94
95		# Compute resulting quantiles
96	1x	quants <- matrix(
97	1x	nrow = length(dosegrid),
98	1x	ncol = 3L
99		)
100	1x	colnames(quants) <- c("lower", "median", "upper")
101
102		# Process each dose
103	1x	for (i in seq_along(dosegrid)) {
104		# Create samples of the probability
105	3x	probSamples <- plogis(
106	3x	alphaSamples + betaSamples * log(dosegrid[i] / refDose)
107		)
108
109		# Compute lower, median and upper quantile
110	3x	quants[i, ] <- quantile(
111	3x	probSamples,
112	3x	probs = c((1 - level) / 2, 0.5, (1 + level) / 2)
113		)
114		}
115
116		# Compute the target value
117	1x	ret <- max(abs(quants - c(lower, median, upper)))
118	1x	structure(ret, mean = mean, cov = cov, quantiles = quants)
119		}
120		}
121
122		# Quantiles2LogisticNormal ----
123
124		#' Convert Prior Quantiles to Logistic (Log) Normal Model
125		#'
126		#' @description `r lifecycle::badge("stable")`
127		#'
128		#' This function uses generalized simulated annealing to optimize
129		#' a [`LogisticNormal`] model to be as close as possible
130		#' to the given prior quantiles.
131		#'
132		#' @param dosegrid (`numeric`)\cr the dose grid.
133		#' @param refDose (`number`)\cr the reference dose.
134		#' @param lower (`numeric`)\cr the lower quantiles.
135		#' @param median (`numeric`)\cr the medians.
136		#' @param upper (`numeric`)\cr the upper quantiles.
137		#' @param level (`number`)\cr the credible level of the (lower, upper) intervals.
138		#' Default is 0.95.
139		#' @param logNormal (`flag`)\cr use the log-normal prior? If `FALSE` (default),
140		#' the normal prior for the logistic regression coefficients is used.
141		#' @param parstart (`numeric` or `NULL`)\cr starting values for the parameters.
142		#' By default, these are determined from the medians supplied.
143		#' @param parlower (`numeric`)\cr lower bounds on the parameters (intercept alpha
144		#' and the slope beta, the corresponding standard deviations and the correlation).
145		#' @param parupper (`numeric`)\cr upper bounds on the parameters.
146		#' @param seed (`count`)\cr seed for random number generation.
147		#' @param verbose (`flag`)\cr should the function be verbose?
148		#' @param control (`list`)\cr additional options for the optimisation routine,
149		#' see [GenSA::GenSA()] for more details.
150		#'
151		#' @return A list with the best approximating `model`
152		#' ([`LogisticNormal`] or [`LogisticLogNormal`]), the resulting `quantiles`,
153		#' the `required` quantiles and the `distance` to the required quantiles,
154		#' as well as the final `parameters` (which could be used for running the
155		#' algorithm a second time).
156		#'
157		#' @importFrom GenSA GenSA
158		#' @importFrom mvtnorm rmvnorm
159		#' @export
160		Quantiles2LogisticNormal <- function(
161		dosegrid,
162		refDose,
163		lower,
164		median,
165		upper,
166		level = 0.95,
167		logNormal = FALSE,
168		parstart = NULL,
169		parlower = c(-10, -10, 0, 0, -0.95),
170		parupper = c(10, 10, 10, 10, 0.95),
171		seed = 12345,
172		verbose = TRUE,
173		control = list(
174		threshold.stop = 0.01,
175		maxit = 50000,
176		temperature = 50000,
177		max.time = 600
178		)
179		) {
180		# Argument validation
181	!	assert_numeric(
182	!	dosegrid,
183	!	min.len = 1,
184	!	any.missing = FALSE,
185	!	sorted = TRUE,
186	!	unique = TRUE
187		)
188	!	assert_number(refDose, finite = TRUE)
189	!	assert_numeric(lower, len = length(dosegrid), any.missing = FALSE)
190	!	assert_numeric(
191	!	median,
192	!	len = length(dosegrid),
193	!	any.missing = FALSE,
194	!	sorted = TRUE
195		)
196	!	assert_numeric(upper, len = length(dosegrid), any.missing = FALSE)
197	!	assert_probability(level, bounds_closed = FALSE)
198	!	assert_flag(logNormal)
199	!	assert_numeric(parstart, len = 5, null.ok = TRUE)
200	!	assert_numeric(parlower, len = 5, any.missing = FALSE)
201	!	assert_numeric(parupper, len = 5, any.missing = FALSE)
202	!	assert_count(seed, positive = TRUE)
203	!	assert_flag(verbose)
204	!	assert_list(control)
205
206		# Additional validation
207	!	assert_true(all(lower < median))
208	!	assert_true(all(median < upper))
209	!	assert_true(all(parlower < parupper))
210	!	if (!is.null(parstart)) {
211	!	assert_true(all(parlower < parstart))
212	!	assert_true(all(parstart < parupper))
213		}
214
215	!	nDoses <- length(dosegrid)
216	!	control$verbose <- verbose
217
218	!	startValues <- h_get_quantiles_start_values(
219	!	parstart = parstart,
220	!	median = median,
221	!	dosegrid = dosegrid,
222	!	refDose = refDose,
223	!	logNormal = logNormal
224		)
225
226	!	target <- h_quantiles_target_function(
227	!	dosegrid = dosegrid,
228	!	refDose = refDose,
229	!	lower = lower,
230	!	median = median,
231	!	upper = upper,
232	!	level = level,
233	!	logNormal = logNormal,
234	!	seed = seed
235		)
236
237	!	set.seed(seed)
238		# Optimize the target function
239	!	genSAres <- GenSA::GenSA(
240	!	par = startValues,
241	!	fn = target,
242	!	lower = parlower,
243	!	upper = parupper,
244	!	control = control
245		)
246	!	distance <- genSAres$value
247	!	pars <- genSAres$par
248	!	targetRes <- target(pars)
249
250		# Construct the model
251	!	model <- if (logNormal) {
252	!	LogisticLogNormal(
253	!	mean = attr(targetRes, "mean"),
254	!	cov = attr(targetRes, "cov"),
255	!	ref_dose = refDose
256		)
257		} else {
258	!	LogisticNormal(
259	!	mean = attr(targetRes, "mean"),
260	!	cov = attr(targetRes, "cov"),
261	!	ref_dose = refDose
262		)
263		}
264
265	!	list(
266	!	model = model,
267	!	parameters = pars,
268	!	quantiles = attr(targetRes, "quantiles"),
269	!	required = cbind(lower, median, upper),
270	!	distance = distance
271		)
272		}
273
274		#' Helper for Minimal Informative Unimodal Beta Distribution
275		#'
276		#' As defined in \insertCite{NeuenschwanderBransonGsponer2008;textual}{crmPack}, this function
277		#' computes the parameters of the minimal informative unimodal beta distribution, given the
278		#' request that the p-quantile should be q, i.e. `X ~ Be(a, b)` with
279		#' `Pr(X <= q) = p`.
280		#'
281		#' @param p (`number`)\cr the probability.
282		#' @param q (`number`)\cr the quantile.
283		#' @return A list with the two resulting beta parameters `a` and `b`.
284		#'
285		#' @keywords internal
286		#' @references
287		#' \insertAllCited{}
288		h_get_min_inf_beta <- function(p, q) {
289	3x	assert_probability(p, bounds_closed = FALSE)
290	3x	assert_probability(q, bounds_closed = FALSE)
291
292	3x	if (q > p) {
293	1x	list(
294	1x	a = log(p) / log(q),
295	1x	b = 1
296		)
297		} else {
298	2x	list(
299	2x	a = 1,
300	2x	b = log(1 - p) / log(1 - q)
301		)
302		}
303		}
304
305		# MinimalInformative ----
306
307		#' Construct a Minimally Informative Prior
308		#'
309		#' @description `r lifecycle::badge("stable")`
310		#'
311		#' This function constructs a minimally informative prior, which is captured in
312		#' a [`LogisticNormal`] (or [`LogisticLogNormal`]) object.
313		#'
314		#' Based on the proposal by \insertCite{NeuenschwanderBransonGsponer2008;textual}{crmPack},
315		#' a minimally informative prior distribution is constructed. The
316		#' required key input is the minimum (\eqn{d_{1}} in the notation of the
317		#' Appendix A.1 of that paper) and the maximum value (\eqn{d_{J}}) of the dose
318		#' grid supplied to this function. Then `threshmin` is the probability
319		#' threshold \eqn{q_{1}}, such that any probability of DLT larger than
320		#' \eqn{q_{1}} has only 5% probability. Therefore \eqn{q_{1}} is the 95%
321		#' quantile of the beta distribution and hence \eqn{p_{1} = 0.95}. Likewise,
322		#' `threshmax` is the probability threshold \eqn{q_{J}}, such that any
323		#' probability of DLT smaller than \eqn{q_{J}} has only 5% probability
324		#' (\eqn{p_{J} = 0.05}). The probabilities \eqn{1 - p_{1}} and \eqn{p_{J}} can be
325		#' controlled with the arguments `probmin` and `probmax`, respectively.
326		#' Subsequently, for all doses supplied in the
327		#' `dosegrid` argument, beta distributions are set up from the assumption
328		#' that the prior medians are linear in log-dose on the logit scale, and
329		#' [Quantiles2LogisticNormal()] is used to transform the resulting
330		#' quantiles into an approximating [`LogisticNormal`] (or
331		#' [`LogisticLogNormal`]) model. Note that the reference dose
332		#' is not required for these computations.
333		#'
334		#' @param dosegrid (`numeric`)\cr the dose grid.
335		#' @param refDose (`number`)\cr the reference dose.
336		#' @param threshmin (`number`)\cr any toxicity probability above this threshold
337		#' would be very unlikely (see `probmin`) at the minimum dose.
338		#' @param threshmax (`number`)\cr any toxicity probability below this threshold
339		#' would be very unlikely (see `probmax`) at the maximum dose.
340		#' @param probmin (`number`)\cr the prior probability of exceeding `threshmin`
341		#' at the minimum dose.
342		#' @param probmax (`number`)\cr the prior probability of being below `threshmax`
343		#' at the maximum dose.
344		#' @param ... additional arguments for computations, see
345		#' [Quantiles2LogisticNormal()], e.g. `refDose` and
346		#' `logNormal=TRUE` to obtain a minimal informative log normal prior.
347		#'
348		#' @return See [Quantiles2LogisticNormal()].
349		#'
350		#' @example examples/MinimalInformative.R
351		#' @export
352		#' @references
353		#' \insertAllCited{}
354		MinimalInformative <- function(
355		dosegrid,
356		refDose,
357		threshmin = 0.2,
358		threshmax = 0.3,
359		probmin = 0.05,
360		probmax = 0.05,
361		...
362		) {
363		# Argument validation
364	!	assert_numeric(
365	!	dosegrid,
366	!	min.len = 1,
367	!	any.missing = FALSE,
368	!	sorted = TRUE,
369	!	unique = TRUE
370		)
371	!	assert_number(refDose, finite = TRUE)
372	!	assert_probability(threshmin, bounds_closed = FALSE)
373	!	assert_probability(threshmax, bounds_closed = FALSE)
374	!	assert_probability(probmin, bounds_closed = FALSE)
375	!	assert_probability(probmax, bounds_closed = FALSE)
376
377	!	nDoses <- length(dosegrid)
378	!	xmin <- dosegrid[1]
379	!	xmax <- dosegrid[nDoses]
380
381		# Derive the beta distributions at the lowest and highest dose
382	!	betaAtMin <- h_get_min_inf_beta(
383	!	q = threshmin,
384	!	p = 1 - probmin
385		)
386	!	betaAtMax <- h_get_min_inf_beta(
387	!	q = threshmax,
388	!	p = probmax
389		)
390
391		# Get the medians of those beta distributions
392	!	medianMin <- with(betaAtMin, qbeta(p = 0.5, a, b))
393	!	medianMax <- with(betaAtMax, qbeta(p = 0.5, a, b))
394
395		# Determine the medians of all beta distributions
396	!	beta <- (logit(medianMax) - logit(medianMin)) / (log(xmax) - log(xmin))
397	!	alpha <- logit(medianMax) - beta * log(xmax / refDose)
398	!	medianDosegrid <- plogis(alpha + beta * log(dosegrid / refDose))
399
400		# Calculate 95% credible interval bounds (lower and upper) for all doses
401	!	lower <- upper <- dosegrid
402	!	for (i in seq_along(dosegrid)) {
403		# Get minimal informative beta distribution
404	!	thisMinBeta <- h_get_min_inf_beta(
405	!	p = 0.5,
406	!	q = medianDosegrid[i]
407		)
408
409		# Derive required quantiles
410	!	lower[i] <- with(thisMinBeta, qbeta(p = 0.025, a, b))
411	!	upper[i] <- with(thisMinBeta, qbeta(p = 0.975, a, b))
412		}
413
414		# Transform quantiles to LogisticNormal model
415	!	Quantiles2LogisticNormal(
416	!	dosegrid = dosegrid,
417	!	refDose = refDose,
418	!	lower = lower,
419	!	median = medianDosegrid,
420	!	upper = upper,
421	!	level = 0.95,
422		...
423		)
424		}
425
426		# nolint end

1		#' Helpers for stripping expressions of `covr`-inserted trace code
2		#'
3		#' Workarounds to allow the package to continue to work while running `covr`
4		#' with minimal changes to the package code.
5		#'
6		#' @details
7		#' When using `covr`, the source code for package objects are modified to add
8		#' callbacks for each expression to log its execution. Given an arbitrary
9		#' expression, such as:
10		#'
11		#' expr
12		#'
13		#' The code will be modified before executing any package code to look like:
14		#'
15		#' if (TRUE) {
16		#' covr:::count("file.R:1:2:3:4:5:6:7:8")
17		#' expr
18		#' }
19		#'
20		#' These functions are used for stripping expressions of this code so that the
21		#' package continues to work as intended while running tests as part of running
22		#' `covr` to calculate package coverage.
23		#'
24		#' This method is non-exhaustive, covering only a subset of `covr`'s tracing
25		#' behaviors necessary for this package.
26		#'
27		#' @param expr (`language`)\cr an R expression or call to test or strip of
28		#' `covr` trace counters.
29		#'
30		#' @return A logical value or transformed expression with calls to
31		#' `covr:::count` removed.
32		#'
33		#' @name h_covr_helpers
34		#' @keywords internal
35		#'
36		NULL
37
38		#' @describeIn h_covr_helpers
39		#' Determine whether `covr` is currently running
40		h_covr_active <- function() {
41	20887x	identical(Sys.getenv("R_COVR"), "true")
42		}
43
44		#' @describeIn h_covr_helpers
45		#' Remove `covr` traces from an expression
46		h_covr_detrace <- function(expr) {
47	20381x	if (!h_covr_active()) {
48	2x	return(expr)
49		}
50
51	20379x	if (is.function(expr)) {
52	9x	body(expr) <- h_covr_detrace(body(expr))
53	9x	return(expr)
54		}
55
56	20370x	detrace <- function(x) {
57		# returns "missing" expression to avoid errors with calls
58	20370x	if (identical(x, bquote())) {
59	26x	return(x)
60		}
61
62	20344x	x <- h_covr_detrace_call(x)
63	20344x	if (is.call(x)) {
64	9873x	x[-1] <- lapply(x[-1], h_covr_detrace)
65		}
66	20344x	x
67		}
68
69	20370x	detrace(expr)
70		}
71
72		#' @describeIn h_covr_helpers
73		#' Determine whether the current expression is a `covr`-modified expression
74		h_is_covr_trace <- function(expr) {
75		# Matches `if (TRUE) { covr:::count(<trace>); <expr> }` (see covr:::trace_calls).
76	20349x	is.call(expr) &&
77	20349x	expr[[1]] == "if" &&
78	20349x	expr[[2]] == quote(TRUE) &&
79	20349x	expr[[3]][[1]] == "{" &&
80	20349x	length(expr[[3]]) >= 3 &&
81	20349x	is.call(expr[[3]][[2]]) &&
82	20349x	expr[[3]][[2]][[1]] == call(":::", as.symbol("covr"), as.symbol("count"))
83		}
84
85		#' @describeIn h_covr_helpers
86		#' Extract the original expression from a `covr`-modified expression
87		h_covr_detrace_call <- function(expr) {
88	1486x	if (h_is_covr_trace(expr)) expr[[3]][[3]] else expr
89		}

1		#' Convenience function to make barplots of percentages
2		#'
3		#' @param x vector of samples
4		#' @param description xlab string
5		#' @param xaxisround rounding for xaxis labels (default: 0, i.e. integers will
6		#' be used)
7		#'
8		#' @return the ggplot2 object
9		#'
10		#' @keywords internal
11		#' @importFrom ggplot2 ggplot geom_histogram aes xlab ylab xlim
12		h_barplot_percentages <- function(x, description, xaxisround = 0) {
13	6x	assert_number(xaxisround, lower = 0)
14	4x	assert_character(description, len = 1, any.missing = FALSE)
15	2x	assert_numeric(x)
16
17	1x	tabx <- table(x) / length(x)
18	1x	dat <- data.frame(x = as.numeric(names(tabx)), perc = as.numeric(tabx) * 100)
19	1x	ggplot() +
20	1x	geom_bar(
21	1x	aes(x = x, y = perc),
22	1x	data = dat,
23	1x	stat = "identity",
24	1x	position = "identity",
25	1x	width = ifelse(nrow(dat) > 1, min(diff(dat$x)) / 2, 1)
26		) +
27	1x	xlab(description) +
28	1x	ylab("Percent") +
29	1x	scale_x_continuous(
30	1x	breaks = round(dat$x, xaxisround)
31		)
32		}
33
34
35		#' Helper function to calculate percentage of true stopping rules for
36		#' report label output
37		#' calculates true column means and converts output into percentages
38		#' before combining the output with the report label; output is passed
39		#' to [`show()`] and output with cat to console
40		#'
41		#' @param stop_report object from summary method
42		#' @return named list with label and percentage of rule activation
43
44		h_calc_report_label_percentage <- function(stop_report) {
45	2x	stop_pct <- colMeans(stop_report) * 100
46	2x	stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
47	2x	stop_pct_to_print
48		}
49
50
51		#' Helper function to calculate average across iterations for each additional
52		#' reporting parameter
53		#' extracts parameter names as specified by user and averaged the values
54		#' for each specified parameter to [`show()`] and output with cat to console
55		#'
56		#' @param stats_list object from simulation with nested parameter values
57		#' (sublist for each parameter)
58		#' @return list of parameter names and averaged values for console output
59
60		h_summarize_add_stats <- function(stats_list) {
61		# Extract the parameter names
62	2x	param_names <- names(stats_list[[1]])
63
64		# Calculate the average for each parameter
65	2x	averages <- lapply(param_names, function(param) {
66	4x	values <- sapply(stats_list, function(x) x[[param]])
67	4x	mean(values)
68		})
69
70	2x	list(param_names, averages)
71		}

1		# GeneralSimulations ----
2
3		#' Internal Helper Functions for Validation of [`GeneralSimulations`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`GeneralSimulations`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_general_simulations
11		#' @param object (`GeneralSimulations`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_general_simulations validates that the [`GeneralSimulations`] object
17		#' contains valid `data` object and valid `dose` simulations.
18
19		v_general_simulations <- function(object) {
20	3x	v <- Validate()
21
22	3x	nSims <- length(object@data)
23
24	3x	v$check(
25	3x	all(sapply(object@data, is, "Data")),
26	3x	"all data elements must be Data objects"
27		)
28	3x	v$check(
29	3x	identical(length(object@doses), nSims),
30	3x	"doses must have same length as the data list"
31		)
32
33	3x	v$result()
34		}
35
36		#' @describeIn v_general_simulations validates that the [`Simulations`] object
37		#' contains valid object `fit`, `stop_reasons`, `stop_report`, and
38		#' `additional_stats` compared to the general class [`GeneralSimulations`].
39		#'
40		v_simulations <- function(object) {
41	5x	v <- Validate()
42
43	5x	nSims <- length(object@data)
44
45	5x	v$check(
46	5x	identical(length(object@fit), nSims),
47	5x	"fit must have same length as data"
48		)
49	5x	v$check(
50	5x	identical(length(object@stop_reasons), nSims),
51	5x	"stop_reasons must have same length as data"
52		)
53
54	5x	v$check(
55	5x	checkmate::test_matrix(
56	5x	object@stop_report,
57	5x	mode = "logical",
58	5x	nrows = nSims,
59	5x	min.cols = 1,
60	5x	any.missing = FALSE
61		),
62	5x	"stop_report must be a matrix of mode logical in which the number of rows
63	5x	equals the number of simulations and which must not contain any missing values"
64		)
65
66	5x	v$result()
67		}
68
69		#' @describeIn v_general_simulations validates that the [`DualSimulations`] object and
70		#' capture the dose-biomarker `fits`, and the `sigma2W` and `rho` estimates.
71		#'
72		v_dual_simulations <- function(object) {
73	4x	v <- Validate()
74
75	4x	nSims <- length(object@data)
76
77	4x	v$check(
78	4x	identical(length(object@fit_biomarker), nSims),
79	4x	"fit_biomarker list has to have same length as data"
80		)
81	4x	v$check(
82	4x	identical(length(object@rho_est), nSims),
83	4x	"rho_est vector has to have same length as data"
84		)
85	4x	v$check(
86	4x	identical(length(object@sigma2w_est), nSims),
87	4x	"sigma2w_est has to have same length as data"
88		)
89
90	4x	v$result()
91		}
92
93		# PseudoSimulations ----
94
95		#' Internal Helper Functions for Validation of [`PseudoSimulations`] Objects
96		#'
97		#' @description `r lifecycle::badge("stable")`
98		#'
99		#' These functions are only used internally to validate the format of an input
100		#' [`PseudoSimulations`] or inherited classes and therefore not exported.
101		#'
102		#' @name v_pseudo_simulations
103		#' @param object (`PseudoSimulations`)\cr object to validate.
104		#' @return A `character` vector with the validation failure messages,
105		#' or `TRUE` in case validation passes.
106		NULL
107
108		#' @describeIn v_pseudo_simulations validates that the [`PseudoSimulations`] object
109		#' contains valid `fit`, `FinalTDtargetEndOfTrialEstimates` ,
110		#' `FinalTDtargetDuringTrialAtDoseGrid`,`FinalTDtargetEndOfTrialAtDoseGrid` ,
111		#' `FinalTDEOTCIs`, `FinalTDEOTRatios`, `FinalCIs`, `FinalRatios`,
112		#' object and valid `stopReasons` simulations.
113
114		v_pseudo_simulations <- function(object) {
115	2x	v <- Validate()
116
117	2x	nSims <- length(object@data)
118	2x	v$check(
119	2x	identical(length(object@stop_reasons), nSims),
120	2x	"stopReasons must have same length as data"
121		)
122
123	2x	v$result()
124		}
125
126		#' @describeIn v_pseudo_simulations validates that the [`PseudoDualSimulations`] object
127		#' contains valid `fit_eff`, `final_gstar_estimates` , `final_gstar_at_dose_grid`,
128		#' `final_gstar_cis` , `final_gstar_ratios`, `final_optimal_dose`, `final_optimal_dose_at_dose_grid`
129		#' object and valid `sigma2_est` simulations.
130
131		v_pseudo_dual_simulations <- function(object) {
132	2x	v <- Validate()
133	2x	nSims <- length(object@data)
134	2x	v$check(
135	2x	identical(length(object@sigma2_est), nSims),
136	2x	"sigma2_est has to have same length as data"
137		)
138	2x	v$result()
139		}
140
141		#' @describeIn v_pseudo_simulations validates that the [`PseudoDualFlexiSimulations`]
142		#' object contains valid `sigma2_beta_w_est` vector of the final posterior mean
143		#' sigma2betaW estimates.`FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
144		#'
145		v_pseudo_dual_flex_simulations <- function(object) {
146	2x	v <- Validate()
147	2x	nSims <- length(object@data)
148	2x	v$check(
149	2x	identical(length(object@sigma2_beta_w_est), nSims),
150	2x	"sigma2_beta_w_est has to have same length as data"
151		)
152	2x	v$result()
153		}
154
155		#' @describeIn v_general_simulations validates that the [`DASimulations`] object
156		#' contains valid `trial_duration` the vector of trial duration values for all
157		#' simulations.
158
159		v_da_simulations <- function(object) {
160	2x	v <- Validate()
161
162	2x	nSims <- length(object@data)
163
164	2x	v$check(
165	2x	identical(length(object@trial_duration), nSims),
166	2x	"trial_duration vector has to have same length as data"
167		)
168
169	2x	v$result()
170		}

1		#' Helper Function to Blind Plot Data
2		#'
3		#' @param df (`GeneralData`)\cr The data to be blinded
4		#' @param blind (`flag`)\cr Should the data be blinded?
5		#' @param has_placebo (`flag`)\cr Does the data contain a placebo dose?
6		#' @param pbo_dose (`positive_number`)\cr The dose to be taken as placebo.
7		#' Ignored if `has_placebo` is `FALSE`
8		#' @returns The blinded data
9		h_blind_plot_data <- function(df, blind, has_placebo, pbo_dose) {
10	19x	if (blind) {
11		# This is to blind the data.
12		# For each cohort, all DLTs are assigned to the first subjects in the cohort.
13		# In addition, the placebo (if any) is set to the active dose level for that
14		# cohort.
15		# Notice: dapply reorders records of df according to the lexicographic order
16		# of cohort.
17	9x	df <- dapply(df, f = ~cohort, FUN = function(coh) {
18	30x	coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
19	30x	coh$dose <- max(coh$dose)
20	30x	coh
21		})
22	10x	} else if (has_placebo) {
23		# Placebo will be plotted at y = 0 level.
24	8x	df$dose[df$dose == pbo_dose] <- 0
25		}
26	19x	df
27		}
28
29		# h_plot_data_df ----
30
31		## generic ----
32
33		#' Helper Function for the Plot Method of subclasses of [`GeneralData`]
34		#'
35		#' @description `r lifecycle::badge("experimental")`
36		#'
37		#' A method that transforms [`GeneralData`] objects into a `tibble` suitable for
38		#' plotting with `ggplot2` methods
39		#'
40		#' @param data (`GeneralData`)\cr object from which data is extracted and converted
41		#' into a data frame.
42		#' @param ... further arguments passed to class-specific methods.
43		#' @return `data.frame` containing columns for patient, cohort, dose and toxicity grade
44		#' @aliases h_plot_data_df
45		#'
46		setGeneric(
47		name = "h_plot_data_df",
48		def = function(data, ...) standardGeneric("h_plot_data_df"),
49		valueClass = "data.frame"
50		)
51
52		# Data ----
53
54		#' Helper Function for the Plot Method of [`Data`]
55		#'
56		#' @param data (`Data`)\cr object from which data is extracted and converted
57		#' into a data frame.
58		#' @param blind (`flag`)\cr should data be blinded?
59		#' If `TRUE`, then for each cohort, all DLTs are assigned to the first
60		#' subjects in the cohort. In addition, the placebo (if any) is set to the
61		#' active dose level for that cohort.
62		#' @param legend (`flag`)\cr Display the legend for the toxicity categories
63		#' @param ... further arguments passed to `data.frame` constructor.
64		#' It can be e.g. an extra `column_name = value` pair based on a slot
65		#' from `x` (which in this case might be a subclass of `Data`)
66		#' which does not appear in `Data`.
67		#' @return A `data.frame` object with columns patient, ID, cohort, dose and
68		#' toxicity.
69		#' @describeIn h_plot_data_df method for [`Data`].
70		setMethod(
71		f = "h_plot_data_df",
72		signature = signature(data = "Data"),
73		definition = function(data, blind = FALSE, legend = TRUE, ...) {
74	17x	df <- data.frame(
75	17x	patient = seq_along(data@x),
76	17x	ID = paste(" ", data@ID),
77	17x	cohort = data@cohort,
78	17x	dose = data@x,
79	17x	toxicity = ifelse(data@y == 1, "Yes", "No"),
80		...
81		)
82	17x	df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
83	17x	df
84		}
85		)
86
87		# DataOrdinal ----
88
89		#' Helper Function for the Plot Method of [`DataOrdinal`]
90		#'
91		#' @describeIn h_plot_data_df Class specific method for [`DataOrdinal`]
92		setMethod(
93		f = "h_plot_data_df",
94		signature = signature(data = "DataOrdinal"),
95		definition = function(data, blind = FALSE, legend = TRUE, ...) {
96	2x	df <- data.frame(
97	2x	patient = seq_along(data@x),
98	2x	ID = paste(" ", data@ID),
99	2x	cohort = data@cohort,
100	2x	dose = data@x,
101	2x	toxicity = names(data@yCategories)[1 + data@y],
102		...
103		)
104	2x	df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
105	2x	df
106		}
107		)
108
109
110		# h_plot_data_dataordinal
111
112		## Data ----
113
114		#' Helper Function for the Plot Method of the Data and DataOrdinal Classes
115		#'
116		#' @description `r lifecycle::badge("stable")`
117		#'
118		#' A method that creates a plot for [`Data`] and [`DataOrdinal`] objects.
119		#'
120		#' @note The default values of `tox_shapes` and `tox_labels` result in DLTs
121		#' being displayed as red triangles and other responses as black circles.
122		#' @return The [`ggplot2`] object.
123		#'
124		#' @rdname plot-Data
125		h_plot_data_dataordinal <- function(
126		x,
127		blind = FALSE,
128		legend = TRUE,
129		tox_labels = c(Yes = "red", No = "black"),
130		tox_shapes = c(Yes = 17L, No = 16L),
131		...
132		) {
133	10x	assert_flag(blind)
134	10x	assert_flag(legend)
135	10x	assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
136	10x	assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
137	10x	assert_true(length(tox_shapes) == length(tox_labels))
138	10x	assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
139	10x	if (x@nObs == 0L) {
140	!	return()
141		}
142	10x	df <- h_plot_data_df(x, blind, ...)
143
144	10x	p <- ggplot(df, aes(x = patient, y = dose)) +
145	10x	geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
146	10x	scale_colour_manual(
147	10x	name = "Toxicity",
148	10x	values = tox_labels,
149	10x	breaks = names(tox_labels),
150	10x	guide = guide_legend(reverse = TRUE)
151		) +
152	10x	scale_shape_manual(
153	10x	name = "Toxicity",
154	10x	values = tox_shapes,
155	10x	breaks = names(tox_shapes),
156	10x	guide = guide_legend(reverse = TRUE)
157		) +
158	10x	scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
159	10x	scale_y_continuous(
160	10x	breaks = sort(unique(c(0, df$dose))),
161	10x	minor_breaks = NULL,
162	10x	limits = c(0, max(df$dose) * 1.1)
163		) +
164	10x	xlab("Patient") +
165	10x	ylab("Dose Level")
166
167	10x	p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)
168
169	10x	if (!blind) {
170	4x	p <- p +
171	4x	geom_text(
172	4x	aes(label = ID, size = 2),
173	4x	data = df,
174	4x	hjust = 0,
175	4x	vjust = 0.5,
176	4x	angle = 90,
177	4x	colour = "black",
178	4x	show.legend = FALSE
179		)
180		}
181
182	10x	if (!legend) {
183	6x	p <- p + theme(legend.position = "none")
184		}
185
186	10x	p
187		}
188
189		#' Helper Function Containing Common Functionality
190		#'
191		#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
192		#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
193		#' range is required
194		#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
195		#'
196		h_obtain_dose_grid_range <- function(object, ignore_placebo) {
197	38x	assert_flag(ignore_placebo)
198
199	36x	dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
200	6x	object@doseGrid[-1]
201		} else {
202	30x	object@doseGrid
203		}
204
205	36x	if (length(dose_grid) == 0L) {
206	10x	c(-Inf, Inf)
207		} else {
208	26x	range(dose_grid)
209		}
210		}
211
212		#' Convert a Ordinal Data to the Equivalent Binary Data for a Specific
213		#' Grade
214		#'
215		#' @description `r lifecycle::badge("experimental")`
216		#'
217		#' A simple helper function that takes a [`DataOrdinal`] object and an
218		#' integer grade and converts them to the equivalent `Data` object.
219		#'
220		#' @param data_ord (`DataOrdinal`)\cr the `DataOrdinal` object to covert
221		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
222		#' is required.
223		#' @return A [`Data`] object.
224		#'
225		#' @export
226		h_convert_ordinal_data <- function(data_ord, grade) {
227		# Validate
228	!	assert_integer(grade, len = 1, lower = 1)
229	!	assert_class(data_ord, "DataOrdinal")
230		# Execute
231	!	Data(
232	!	ID = data_ord@ID,
233	!	cohort = data_ord@cohort,
234	!	x = data_ord@x,
235	!	y = as.integer(data_ord@y >= grade),
236	!	doseGrid = data_ord@doseGrid,
237	!	nGrid = data_ord@nGrid,
238	!	xLevel = data_ord@xLevel,
239	!	placebo = data_ord@placebo
240		)
241		}

1		#' @include helpers.R
2		#' @include McmcOptions-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# McmcOptions ----
7
8		## class ----
9
10		#' `McmcOptions`
11		#'
12		#' @description `r lifecycle::badge("stable")`
13		#'
14		#' [`McmcOptions`] is a class for the three canonical MCMC options as well as
15		#' Random Number Generator settings.
16		#'
17		#' @slot iterations (`count`)\cr number of MCMC iterations.
18		#' @slot burnin (`count`)\cr number of burn-in iterations which are not saved.
19		#' @slot step (`count`)\cr only every `step`-th iteration is saved after
20		#' the `burnin`. In other words, a sample from iteration
21		#' `i = 1,...,iterations`, is saved if and only if
22		#' `(i - burnin) mod step = 0`.\cr
23		#' For example, for `iterations = 6`, `burnin = 0` and `step = 2`, only
24		#' samples from iterations `2,4,6` will be saved.
25		#' @slot rng_kind (`string`)\cr a Random Number Generator (RNG) type used by
26		#' [`rjags`]. It must be one out of the following four values:
27		#' `base::Wichmann-Hill`, `base::Marsaglia-Multicarry`,
28		#' `base::Super-Duper`, `base::Mersenne-Twister`, or `NA_character_`.
29		#' If it is `NA_character_` (default), then the RNG kind will be chosen by
30		#' [`rjags`].
31		#' @slot rng_seed (`number`)\cr a Random Number Generator (RNG) seed
32		#' used by [`rjags`] for a chosen `rng_kind`. It must be an integer scalar or
33		#' `NA_integer_`, which means that the seed will be chosen by [`rjags`].
34		#'
35		#' @aliases McmcOptions
36		#' @export
37		#'
38		.McmcOptions <- setClass(
39		Class = "McmcOptions",
40		slots = c(
41		iterations = "integer",
42		burnin = "integer",
43		step = "integer",
44		rng_kind = "character",
45		rng_seed = "integer"
46		),
47		prototype = prototype(
48		iterations = 1000L,
49		burnin = 100L,
50		step = 2L,
51		rng_kind = NA_character_,
52		rng_seed = NA_integer_
53		),
54		contains = "CrmPackClass",
55		validity = v_mcmc_options
56		)
57
58		## constructor ----
59
60		#' @rdname McmcOptions-class
61		#'
62		#' @param burnin (`count`)\cr number of burn-in iterations which are not saved.
63		#' @param step (`count`)\cr only every step-th iteration is saved after
64		#' the burn-in.
65		#' @param samples (`count`)\cr number of resulting samples.
66		#' @param rng_kind (`string`)\cr the name of the RNG type. Possible types are:
67		#' `Wichmann-Hill`, `Marsaglia-Multicarry`, `Super-Duper`, `Mersenne-Twister`.
68		#' If it is `NA` (default), then the RNG kind will be chosen by `[rjags`].
69		#' @param rng_seed (`number`)\cr RNG seed corresponding to chosen `rng_kind`.
70		#' It must be an integer value or `NA` (default), which means that the seed
71		#' will be chosen by `[rjags`].
72		#'
73		#' @export
74		#' @example examples/McmcOptions-class-McmcOptions.R
75		#'
76		McmcOptions <- function(
77		burnin = 1e4L,
78		step = 2L,
79		samples = 1e4L,
80		rng_kind = NA_character_,
81		rng_seed = NA_integer_
82		) {
83	302x	assert_count(burnin, positive = TRUE)
84	302x	assert_count(step, positive = TRUE)
85	302x	assert_count(samples, positive = TRUE)
86	302x	assert_string(rng_kind, na.ok = TRUE)
87	302x	assert_count(rng_seed, na.ok = TRUE)
88
89	302x	if (!is.na(rng_kind)) {
90	223x	rng_kind <- paste0("base::", rng_kind)
91		} else {
92	79x	rng_kind <- NA_character_
93		}
94	302x	if (!is.na(rng_seed)) {
95	222x	rng_seed <- as.integer(rng_seed)
96		} else {
97	80x	rng_seed <- NA_integer_
98		}
99
100	302x	.McmcOptions(
101	302x	iterations = as.integer(burnin + (step * samples)),
102	302x	burnin = as.integer(burnin),
103	302x	step = as.integer(step),
104	302x	rng_kind = rng_kind,
105	302x	rng_seed = as.integer(rng_seed)
106		)
107		}
108
109		## default constructor ----
110
111		#' @rdname McmcOptions-class
112		#' @note Typically, end users will not use the `.DefaultMcmcOptions()` function.
113		#' @export
114		.DefaultMcmcOptions <- function() {
115	9x	McmcOptions(
116	9x	burnin = 250,
117	9x	samples = 1000
118		)
119		}

1		# tidy ----
2
3		## generic ----
4
5		#' Tidying `CrmPackClass` objects
6		#'
7		#' @description `r lifecycle::badge("experimental")`
8		#'
9		#' In the spirit of the `broom` package, provide a method to convert a
10		#' `CrmPackClass` object to a (list of) tibbles.
11		#'
12		#' @param x (`CrmPackClass`)\cr the object to be tidied.
13		#' @param ... potentially used by class-specific methods
14		#'
15		#' @return A (list of) tibble(s) representing the object in tidy form.
16		#'
17		#' @export
18		#'
19		setGeneric(
20		name = "tidy",
21		def = function(x, ...) {
22	620x	standardGeneric("tidy")
23		}
24		)
25
26		## CrmPackClass ----
27
28		#' Tidy a `CrmPackClass` Object
29		#'
30		#' Following the principles of the `broom` package, convert a `CrmPackClass`
31		#' object to a (list of) tibbles. This is a basic, default representation.
32		#'
33		#' @param x (`CrmPackClass`)\cr the object to be tidied.
34		#' @param ... potentially used by class-specific methods.
35		#' @rdname tidy
36		#' @aliases tidy-CrmPackClass
37		#' @keywords methods
38		#' @example examples/CrmPackClass-method-tidy.R
39		#'
40		#' @export
41		setMethod(
42		f = "tidy",
43		signature = signature(x = "CrmPackClass"),
44		definition = function(x, ...) {
45	394x	rv <- h_tidy_all_slots(x) %>% h_tidy_class(x)
46	394x	if (length(rv) == 1) {
47	72x	rv[[names(rv)[1]]] %>% h_tidy_class(x)
48		} else {
49	322x	rv
50		}
51		}
52		)

1		#' Verbose Logging
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' A family of wrappers of selected [`futile.logger`] functions that control
6		#' the logging mechanism in `crmPack`. The `crmPack` uses [`futile.logger`]
7		#' package for the logging purposes. All the messages logged in `crmPack` are
8		#' logged into `crmPack` logger at the [`futile.logger::TRACE`] level. Hence,
9		#' enabling verbose logging means that the logging threshold will be set to
10		#' [`futile.logger::TRACE`] for the `crmPack` logger, and disabling verbose
11		#' logging means that it will be set to [`futile.logger::FATAL`].
12		#'
13		#' @describeIn enable_logging A simple wrapper of
14		#' [futile.logger::flog.threshold()] that enables `crmPack` verbose logging by
15		#' setting logging threshold to [`futile.logger::TRACE`] for `crmPack` logger.
16		#'
17		#' @export
18		#'
19		enable_logging <- function() {
20	3x	invisible(
21	3x	futile.logger::flog.threshold(futile.logger::TRACE, name = "crmPack")
22		)
23		}
24
25		#' @describeIn enable_logging A simple wrapper of
26		#' [futile.logger::flog.threshold()] that disables `crmPack` verbose logging
27		#' by setting logging threshold to [`futile.logger::FATAL`] for `crmPack`
28		#' logger.
29		#'
30		#' @export
31		#'
32		disable_logging <- function() {
33	6x	invisible(
34	6x	futile.logger::flog.threshold(futile.logger::FATAL, name = "crmPack")
35		)
36		}
37
38		#' @describeIn enable_logging A simple wrapper of
39		#' [futile.logger::flog.logger()] that checks whether current threshold level
40		#' for `crmPack` logger is verbose, which is [`futile.logger::TRACE`].
41		#' It returns `TRUE` if the current logging level is verbose, `FALSE`
42		#' otherwise.
43		#'
44		#' @export
45		#'
46		is_logging_enabled <- function() {
47	201x	logger <- futile.logger::flog.logger(name = "crmPack")
48	201x	unname(logger$threshold == futile.logger::TRACE)
49		}
50
51		#' @describeIn enable_logging A simple wrapper of
52		#' [futile.logger::flog.trace()] that prints a log message in the `crmPack`
53		#' logger.
54		#'
55		#' @inheritParams futile.logger::flog.trace
56		#'
57		#' @export
58		#'
59		log_trace <- function(msg, ..., capture = FALSE) {
60	296x	assert_string(msg)
61	296x	assert_flag(capture)
62
63	296x	futile.logger::flog.trace(msg = msg, ..., name = "crmPack", capture = capture)
64		}

1		# v_mcmc_options ----
2
3		#' Internal Helper Functions for Validation of [`McmcOptions`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`McmcOptions`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_mcmcoptions_objects
11		#' @param object (`McmcOptions`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_mcmcoptions_objects validates that the [`McmcOptions`]
17		#' object contains valid integer scalars `iterations`, `burnin` and `step`
18		#' as well as proper parameters for Random Number Generator.
19		v_mcmc_options <- function(object) {
20	4x	v <- Validate()
21	4x	allowed_rng_kinds <- c(
22	4x	"base::Wichmann-Hill",
23	4x	"base::Marsaglia-Multicarry",
24	4x	"base::Super-Duper",
25	4x	"base::Mersenne-Twister",
26	4x	NA_character_
27		)
28
29	4x	v$check(
30	4x	test_int(object@iterations, lower = 1L),
31	4x	"iterations must be integer scalar greater than or equal to 1"
32		)
33	4x	v$check(
34	4x	test_int(object@burnin, lower = 0L),
35	4x	"burn-in must be non-negative integer scalar"
36		)
37		# This below check should not be conducted in above test, using
38		# `upper = object@iterations -1` argument, since object@iterations might be
39		# not-valid. In such a case `test_int` throws an internal error.
40	4x	v$check(
41	4x	test_true(object@burnin < object@iterations),
42	4x	"burn-in must be lower than iterations"
43		)
44	4x	v$check(
45	4x	test_int(object@step, lower = 1L),
46	4x	"step must be integer scalar greater than or equal to 1"
47		)
48
49	4x	is_rng_kind_scalar <- test_string(object@rng_kind, na.ok = TRUE)
50	4x	v$check(is_rng_kind_scalar, "rng_kind must be a single string")
51	4x	v$check(
52	4x	test_subset(object@rng_kind, allowed_rng_kinds),
53	4x	paste0(
54	4x	"rng_kind must one of the following: ",
55	4x	paste(allowed_rng_kinds, collapse = ", "),
56	4x	". User specifies the rng_kind without `base::` prefix"
57		)
58		)
59
60	4x	is_rng_seed_scalar <- test_int(object@rng_seed, na.ok = TRUE)
61	4x	v$check(is_rng_seed_scalar, "rng_seed must be an integer scalar")
62
63		# Below `if` condition is not only reasonable but also needed as R CMD check
64		# is activating some stricter checks and it fails when arguments to `\|\|` are
65		# not scalars, even if `\|\|` works well with vectors of length > 1.
66	4x	if (is_rng_kind_scalar && is_rng_seed_scalar) {
67	3x	v$check(
68	3x	!is.na(object@rng_kind) \|\| is.na(object@rng_seed),
69	3x	"rng_seed supplied but rng_kind not set"
70		)
71		}
72	4x	v$result()
73		}

1		#' Check That Labels Are Valid and Useful
2		#'
3		#' A vector of labels is valid and useful if it is of length 2, of type character
4		#' and its values are distinct.
5		#'
6		#' If `x` is a scalar, a second element is added, whose value is the value of the
7		#' scalar with "s" appended. If `x` is `"toxicity"`, the plural is handled appropriately.
8		#'
9		#' @param x (`character`)\cr The vector to be checked
10		#' @keywords internal
11		#' @return a character vector of length 2 whose values are distinct
12		h_prepare_labels <- function(x) {
13	120x	assert_character(
14	120x	x,
15	120x	min.len = 1,
16	120x	max.len = 2,
17	120x	any.missing = FALSE,
18	120x	unique = TRUE
19		)
20
21	118x	if (length(x) == 1) {
22	89x	if (x == "toxicity") {
23	15x	x <- c("toxicity", "toxicities")
24		} else {
25	74x	x[2] <- paste0(x[1], "s")
26		}
27		}
28	118x	x
29		}
30
31		#' Append Units to a Numeric Dose
32		#'
33		#' @param units (`character`)\cr the units to be displayed
34		#' @keywords internal
35		#' @return if `units` is `NA`, then `NA`. Otherwise, `units`, ensuring that exactly
36		#' one space precedes the first non-whitespace character
37		h_prepare_units <- function(units = NA) {
38	24x	assert_character(units, len = 1)
39
40	24x	ifelse(
41	24x	is.na(units),
42		"",
43	24x	paste0(" ", stringr::str_trim(units, "left"))
44		)
45		}

1		#' @include McmcOptions-class.R
2		NULL
3
4		# size ----
5
6		## generic ----
7
8		#' Size of an Object
9		#'
10		#' @description `r lifecycle::badge("stable")`
11		#'
12		#' A method that computes the size of a given object. This can be for instance
13		#' a size of a MCMC sample, or the size of a cohort. See the help of a specific
14		#' method for more details.
15		#'
16		#' @param object (`McmcOptions` or `Samples` or `CohortSize`)\cr an object
17		#' for which the size is computed.
18		#' @param ... further arguments passed to `size` specific methods.
19		#'
20		#' @return A size of a given object.
21		#' @export
22		#'
23		setGeneric(
24		name = "size",
25		def = function(object, ...) {
26	1226x	standardGeneric("size")
27		},
28		valueClass = "integer"
29		)
30
31		## McmcOptions ----
32
33		#' @describeIn size compute the number of MCMC samples based on `McmcOptions`
34		#' object.
35		#' @aliases size-McmcOptions
36		#' @example examples/McmcOptions-methods-size.R
37		setMethod(
38		f = "size",
39		signature = signature(object = "McmcOptions"),
40		definition = function(object, ...) {
41	781x	iterations_relative <- object@iterations - object@burnin
42	781x	if (iterations_relative <= 0) {
43	!	return(0L)
44		}
45	781x	as.integer(floor(iterations_relative / object@step))
46		}
47		)
48
49		# saveSample ----
50
51		## generic ----
52
53		#' Determining if this Sample Should be Saved
54		#'
55		#' @description `r lifecycle::badge("stable")`
56		#'
57		#' A method that determines if a sample from a given `iteration` should be
58		#' saved. The sample should be saved if and only if:
59		#' it is not in burn-in period and it matches the `step`.
60		#'
61		#' @param object (`McmcOptions`)\cr object based on which the answer is
62		#' determined.
63		#' @param iteration (`count`)\cr the current iteration index.
64		#' @param ... not used.
65		#' @return `TRUE` if this sample should be saved.
66		#' @export
67		#'
68		setGeneric(
69		name = "saveSample",
70		def = function(object, iteration, ...) {
71	234x	standardGeneric("saveSample")
72		},
73		valueClass = "logical"
74		)
75
76		## McmcOptions ----
77
78		#' @describeIn saveSample determine if a sample should be saved.
79		#' @aliases saveSample-McmcOptions
80		#' @example examples/McmcOptions-methods-saveSample.R
81		setMethod(
82		f = "saveSample",
83		signature = signature(object = "McmcOptions"),
84		definition = function(object, iteration, ...) {
85	234x	iteration_relative <- iteration - object@burnin
86	234x	iteration_relative > 0 && ((iteration_relative %% object@step) == 0)
87		}
88		)

1		#' Convert a Samples Object from an ordinal Model to the Equivalent Samples Object
2		#' from a Binary Model
3		#'
4		#' @description `r lifecycle::badge("experimental")`
5		#'
6		#' A simple helper function that converts a [`Samples`] object from the fit of an
7		#' ordinal CRM model to that which would have been obtained from fitting a binary
8		#' CRM model for toxicities of a specified grade to the same observed data.
9		#'
10		#' @param obj (`Samples`)\cr the `Samples` object to covert
11		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
12		#' is required.
13		#' @return A [`Samples`] object.
14		#'
15		#' @export
16		h_convert_ordinal_samples <- function(obj, grade) {
17		# Validate
18	6x	assert_integer(grade, len = 1, lower = 1)
19	4x	assert_class(obj, "Samples")
20	3x	assert_subset(c(paste0("alpha", 1:grade), "beta"), names(obj@data))
21		# Execute
22	2x	d <- list(
23	2x	"alpha0" = obj@data[[paste0("alpha", grade)]],
24	2x	"alpha1" = obj@data$beta
25		)
26	2x	Samples(data = d, options = obj@options)
27		}

1		# nolint start
2
3		#' Object-oriented implementation of CRM designs
4		#'
5		#' @name crmPack
6		#' @title Object-oriented implementation of CRM designs
7		#' @import checkmate
8		#' @import ggplot2
9		#' @import methods
10		#' @import tibble
11		#' @importFrom grid grid.draw
12		#' @importFrom gridExtra arrangeGrob
13		#' @importFrom graphics plot hist legend lines matlines matplot
14		#' @importFrom stats binomial coef cov2cor gaussian glm lm median model.matrix
15		#' optim pgamma plogis pnorm qgamma qlogis qnorm quantile rbinom rgamma
16		#' approxfun rnorm runif uniroot var vcov step mad pbeta dbeta dgamma
17		#' setNames
18		#' @importFrom utils data head tail capture.output
19		#' @importFrom lifecycle badge
20		#' @importFrom rjags jags.model jags.samples
21		#' @importFrom futile.logger flog.threshold flog.logger flog.trace TRACE FATAL
22		#' @importFrom knitr knit_print
23		#' @importFrom kableExtra kbl add_header_above column_spec collapse_rows
24		#' kable_styling add_footnote kable
25		#' @importFrom Rdpack reprompt
26		#'
27		#' @keywords package
28		#' @references \insertRef{SabanesBoveYeungPalermoJaki2019}{crmPack}
29		"_PACKAGE"
30
31		##' @keywords internal
32		.onAttach <- function(libname, pkgname) {
33	3x	packageStartupMessage(
34	3x	"Type crmPackHelp() to open help browser\n",
35	3x	"Type crmPackExample() to open example\n"
36		)
37		}
38
39		## need to declare global variable / function
40		## names in order to avoid R CMD check notes:
41		globalVariables(c(
42		"log.betaZ",
43		"precW",
44		"pow",
45		"nObs",
46		"betaZ",
47		"x",
48		"betaW",
49		"xLevel",
50		"precW",
51		"z",
52		"nGrid",
53		"doseGrid",
54		"betaWintercept",
55		"delta",
56		"deltaStart",
57		"delta2",
58		"Effsamples",
59		"logit<-",
60		"rho0",
61		"alpha0",
62		"delta0",
63		"alpha1",
64		"delta1",
65		"inverse",
66		"priorCov",
67		"theta",
68		"comp0",
69		"w",
70		"DLTs",
71		"y",
72		"group",
73		"annotate",
74		"probSamples",
75		"prec",
76		"nu",
77		"samples",
78		"Type",
79		"patient",
80		"toxicity",
81		"ID",
82		"biomarker",
83		"traj",
84		"Statistic",
85		"perc",
86		"..density..",
87		"middle",
88		"lower",
89		"upper",
90		"middleBiomarker",
91		"lowerBiomarker",
92		"upperBiomarker",
93		"nObsshare",
94		"xshare",
95		"yshare",
96		"thisProb.PL",
97		"thisMeanEff.PL",
98		"thisSize.PL",
99		"probit<-",
100		"refDose",
101		"Tmax",
102		"u",
103		"eps",
104		"h",
105		"lambda",
106		"cadj",
107		"A",
108		"lambda_p",
109		"cond",
110		"t0",
111		"tend",
112		"t0_case",
113		"tend_case",
114		"yhat",
115		"ref_dose",
116		"comp",
117		"X",
118		"skel_probs",
119		"is_combo",
120		"results",
121		"k",
122		"value",
123		"Parameter",
124		"intervals",
125		"Group",
126		"Tox",
127		"MaxOverdoseProb",
128		"DoseGrid",
129		"NGrid",
130		"NObs",
131		"XLevel"
132		))
133
134		# nolint end

1		#' @include McmcOptions-methods.R
2		NULL
3
4		# v_samples ----
5
6		#' Internal Helper Functions for Validation of [`Samples`] Objects
7		#'
8		#' @description These functions are only used internally to validate the format
9		#' of an input [`Samples`] or inherited classes and therefore not exported.
10		#'
11		#' @name v_samples_objects
12		#' @param object (`Samples`)\cr object to validate.
13		#' @return A `character` vector with the validation failure messages, or `TRUE`
14		#' in case validation passes.
15		NULL
16
17		#' @describeIn v_samples_objects validates that the [`Samples`] object contains
18		#' valid `data` slot.
19		v_samples <- function(object) {
20	7x	v <- Validate()
21	7x	v$check(
22	7x	all(sapply(object@data, NROW) == size(object@options)),
23	7x	"Every element in data must be of the same length (no. of rows) as the sample size was"
24		)
25	7x	v$check(
26	7x	all(sapply(object@data, test_numeric, finite = TRUE, any.missing = FALSE)),
27	7x	"Every element in data must be a finite object of type integer or double"
28		)
29	7x	v$result()
30		}

1		#' @include McmcOptions-class.R
2		#' @include Samples-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# Samples ----
7
8		## class ----
9
10		#' `Samples`
11		#'
12		#' @description `r lifecycle::badge("stable")`
13		#'
14		#' [`Samples`] is the class to store the MCMC samples.
15		#'
16		#' @slot data (`list`)\cr MCMC samples of the parameter. Each entry in this list
17		#' must be a vector (in case of a scalar parameter) or matrix (in case of a
18		#' vector-valued parameter) with samples.
19		#' In case of matrix, every row is a separate sample, while columns correspond
20		#' to the dimension of the parameter.
21		#' @slot options (`McmcOptions`)\cr MCMC options that were used to generate the
22		#' samples.
23		#'
24		#' @aliases Samples
25		#' @export
26		#'
27		.Samples <- setClass(
28		Class = "Samples",
29		slots = c(
30		data = "list",
31		options = "McmcOptions"
32		),
33		prototype = prototype(
34		data = list(),
35		options = McmcOptions()
36		),
37		contains = "CrmPackClass",
38		validity = v_samples
39		)
40
41		## constructor ----
42
43		#' @rdname Samples-class
44		#'
45		#' @param data see slot definition.
46		#' @param options see slot definition.
47		#'
48		#' @export
49		#' @example examples/Samples-class.R
50		#'
51		Samples <- function(data, options) {
52	313x	new("Samples", data = data, options = options)
53		}
54
55		## default constructor ----
56
57		#' @rdname Samples-class
58		#' @note Typically, end users will not use the `.DefaultSamples()` function.
59		#' @export
60		.DefaultSamples <- function() {
61	3x	mcmc(
62	3x	data = .DefaultData(),
63	3x	model = .DefaultLogisticLogNormal(),
64	3x	options = .DefaultMcmcOptions()
65		)
66		}